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ABSTRACT 


This report describes an automated hospital information system 
that handles all data related to patient-care activities. The report 
is designed to serve as a manual for potential users— nontechnical 
medical personnel who will use the system. Examples of the 
system's operation, commentary on the examples, and a complete 
listing of the system program are included. 
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by 
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United Computing Systems, Inc. 

and 

Ronald A. Schwarz 
Federal City College 

BACKGROUND AND FUNCTION OF MIMS 

The capability of hospitals to maintain medical records is vital to the improve- 
ment of medical services for the average American citizen. These records 
are essential to the diagnosis and treatment of patients and provide an essen- 
tial base for comparative analysis for medical research and hospital adminis- 
tration. 

The Medical Information Management System (MIMS) is a real-time hospital 
information system with teletype input. Its function is to handle all aspects of 
data related to patient care. Its prime benefits are (1) the ability to recall the 
record of a specific patient (or patients) in a matter of seconds, (2) the ability 
to search for specific types of data among patients' records, and (3) the ability 
to do medical research with a rich and readily available data base. 

A computer program initially was developed at NASA/Houston to monitor the 
health status of astronauts and subsequently was continued by Dr. TateMinckler 
at the Presbyterian Hospital in Denver. However, Dr. Minckler's program 
was not fully operational and lacked the documentation required by potential 
users. This past summer^, during the NASA /Morgan Workshop program con- 
ducted at GSFC, Prof. Ronald Schwarz of Federal City College updated the com- 
puter program so that it can be used by anyone and developed a users' manual 
containing complete, easy-to-follow instructions for operating the system. The 
MIMS package on which this users' guide is based is a redesigned and improved 
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model of the previous work of Dr. Minckler; also, the cost of running MIMS on 
a day-in, day-out basis (one of the problems with the earlier system) has been 
reduced. MIMS is written in FORTRAN in a version developed by United Com- 
puting Systems, Inc. In its present form, MIMS can be run only on a CDC 6400 
computer because of the size of the internal word structure. 

The package is a generalized information storage and retrieval system that ena- 
bles the user to accomplish four basic functions: 

• Definition of file structure to accommodate individual needs. 

• Data entry. 

• Data retrieval. 

• Data revision and file maintenance. 

ORGANIZATION OF MIMS 

The MIMS package consists of six programs, each of which operates independ- 
ently but all of which are connected by references to common file names in the 
system. The segments are— 

HEADER: creates categories of data. 

STORE: stores data under the categories from HEADER. 

RETREVE: recalls desired configurations of data. 

UPDATE: alters or deletes specific data items. 

SORTER: rearranges related (data) records. 

MERGE: combines two sets of records. 

The discussion of each of the six program units and the related examples should 
clarify for the potential user the way in which MIMS is used as an automated 
hospital information system. 

The system is user oriented. No technical training is needed to interact with 
the system, except the ability to read and understand this guide. All program 
segments are conversational, with the user responding to questions generated 
by the system. 
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This guide includes examples for almost every option available in MIMS. Ex- 
planation is provided in the text material. System commands —those key words 
or phrases that control activities such as the activation and deactivation of the 
programs— are illustrated, with user responses underlined. In addition, a 
complete listing of the program is provided in the appendix. 


DEFINITIONS 

Several basic terms are used throughout the discussion. For easy reference, 
we define them here: 

• Headings: labels or categories of data which are created during the 
HEADER program. 

• Header file: a group of headings corresponding to a particular data 
record. 

• Header-file name: an acronym by which a header file is known, formed 
from the first three letters of the department name and the first four 
letters of the record. 

• Data field: any group of letters, words, or numbers (or combinations 
of the three) that is a response to a heading. 

• Data record: a logically related set of heading-data pairs for an arbi- 
trary header file. 

• Datafile: a group of data records. 

• Data-file name: the designation by which a set of data records is known; 
it is given during the STORE program. 

® ID items: the first four data fields in a record, namely SOC SEC #, 
DEPT, RECORD, and DATE. 


MIMS: THE SIX PROGRAM UNITS 
HEADER Program 

The HEADER program creates a file of headings or labels for data that will 
subsequently be placed under these headings. Headings may consist of from 
one to 24 (a theoretical maximum) alphabetic and/or numeric characters. As 
many as 160 headings are possible under a single file name. 
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To call the HEADER segment, the user types EXEC, OLD, HEADER (see Figure 

1) . After the teletype responds with READY, the user types RNH. This com- 
mand initiates the running of the program. 

To illustrate an unusual situation, let us assume that by coincidence a second 
user requests ADMINIT as the header file name for his set of headings after 
someone else has already used it. At the conclusion of this input, the second 
user will be informed that he can either place his headings under a new file 
name or replace the first header file with his own by typing an asterisk (Figure 

2) . In the former case, the user must be careful, in the future, to spell the 
name of the department and record in such a way that the creation of the seven- 
letter header file name matches the new one he has suggested. 

If Instructions are Needed. New users may want to reply YES (or just Y) to the 
question DO YOU NEED OPERATING INSTRUCTIONS? In this case, a set of 
instructions on how to use HEADER is printed. The stop skip code (S) enables 
the user to skip selected headings when entering data later. (Figure 1). 

Naming the Header File. A group of headings associated with a set of data 
must have a name by which the group can be identified. The name of a header 
file is formed from the first three letters of the department name and the first 
four letters of the record. Fewer letters are permissible as long as there is 
at least one letter from each. In the sample, ADMINIT is the name of the 
header file. It was created from ADMitting department and from an JNITial 
visit record (Figure 1). 

Level Codes and Headings. Each heading consists of a level code and a heading 
name. The level code, a number from zero to nine, specifies the degree of 
indentation of the heading. A colon must follow each heading for which a re- 
sponse is anticipated. Headings used for organizational purposes only, such as 
PULSE in the header file CARPULS (Figure 3), will not need a colon. [Caution: 
Because of spacing considerations, the higher the level code (that is, the 
greater the indentation of a heading) the fewer the characters available for that 
heading name. ] 

The user types an asterisk to indicate that all level codes and headings for a 
particular file have been supplied. 

Four ID Items. The first four items in a file are used to identify individual 
records. These four entries uniquely identify the data associated with them. 


For illustration purposes only, all underlined items in the figures indicate user 
responses. Nonunderlined items are machine generated. 
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EXEC, OLD, HEADER 


READY. 

BNH 

PROGRAM* HEADER DATE* 08/05/71 TIME* 14.57.28 


THIS PROGRAM WILL BUILD A FILE OF LEVEL CODES AND 
HEADINGS. DO YOU NEED OPERATING INSTRUCTIONS 7 YES 
OK# HERE'S HOW IT'S DONE. WHEN THE FIRST QUESTION 
MARK APPEARS# ENTER A LEVEL CODE (0-9). WHEN THE NEXT 
QUESTION MARK APPEARS # ENTER THE HEADING (FROM 1-24 
CHARACTERS) THAT CORRESPONDS TO YOUR LEVEL CODE. FOR 
HEADINGS THAT WILL NORMALLY HAVE DATA FOLLOWING THEM 
ENTER A COLON AFTER THE HEADING. FOR BLIND HEADINGS 
(THOSE WHICH WILL NOT HAVE DATA FOLLOWING THEM) DO NOT 
ENTER THE COLON. 


REPEAT THIS PROCESS UNTIL YOU HAVE NO MORE HEADINGS- -THEN 
ENTER AN ASTERISK TO TERMINATE THE PROGRAM. 

IF YOU WISH TO ENTER A STOP SKIP CODE# ENTER AN "S" 
INSTEAD OF A LEVEL CODE. THEN ENTER THE LEVEL CODE AND 
HEADING AS USUAL FOLLOWING THE NEXT TWO QUESTION MARKS. 


ENTER 3 LETTERS OF DEPT. NAME AND 4 LETTERS OF RECORD 
— ENTER FEWER IF 7 ARE NOT AVAILABLE 7 ADMIN IT 


BEGIN DATA INPUT. 


7 0 

7~ S0C SEC #* 
7 0 

7 DEPT* 

7 0 

7 RECORD* 

7 0 

7 DATE* 

7 1 

7 NAME* 

7 1 


7 AGE* 

7 i 

7 SEX* 

7 l 

7 ADDRESS* 

7 2 

7 PHONE* 

7 A 

7 COMMENTS* 


7 * 


"ADMINIT" HAS BEEN SAVED 
END. 


AS HEADER FILE. 


0.193 / 0.964 / 5 

Figure 1. ADMINIT Created as Header File 
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EXEC* OLD# HEADER 


BEADY. 

BNH 

PROGRAM* HEADER DATE* 08/05/71 TIME* 15.18.12 


THIS PROGRAM WILL BUILD A PILE OF LEVEL CODES AMD 
HEADINGS. DO YOU NEED OPERATING INSTRUCTIONS ? .NO 


ENTER 3 LETTERS OF DEPT. NAME AND 4 LETTERS OF RECORD 
ENTER FEWER IF 7 ARE NOT AVAILABLE ? ADMINIT 


BEGIN DATA INPUT. 


7 Q 

? SOC SEC St 

? o 

7 DEPT* 

? o 

7 RECORD* 

? Q 

? DATE* 

? I 

7 NAME* 

7 L 

7 EKG* 

7 2 

7 HT* 

7 2 

7 WT* 

7 i 

7 HEART ATTACKS 
7 2 

~7 HOW MANY* 

7 2 

7 DATE MOST RECENT* 

7 i 

7 AVG DURATION* 

7 2 

7 SEVERITY* 

7 L 

V PRESENT CONDITION* 

7 £ 

FILE ALREADY PERMANENT. ENTER NEW FILENAME OR 

ENTER AN ASTERISK TO REPLACE CURRENT PERMANENT FILE* 7 CABHIST 
"CARHIST" HAS BEEN SAVED AS HEADER FILE. 

END. 


0.238 / 1.189 / 10 

Figure 2. ADMINIT Has Been Created (Figure 1) and Is Already a Permanent 
Header File, so CARHIST Is Used as the Header File 
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EXEC* OLD* HEADER 


READY. 

RNH 

PROGRAMI HEADER DATE! 08/05/71 TIME! 15.02.11 


THIS PROGRAM WILL BUILD A FILE OF LEVEL CODES AND 
HEADINGS. DO YOU NEED OPERATING INSTRUCTIONS 7 N 


ENTER 3 LETTERS OF DEPT. NAME AND A LETTERS OF RECORD 
— ENTER FEWER IF 7 ARE NOT AVAILABLE 7 CARPULS 


BEGIN DATA INPUT. 


7 0 

7 SOC SEC #1 
7 0 

?~ DEPTs 
7 0 

7 RECORD! 

7 0 

7 DATE! 

7 1 

7 NAME! 

7 1 

7 PULSE 
7 2 

~7 SITTING I 
7 2 

7 STANDINGS 

7 2 

? AFTER EXERCISE 

7 3 

7 IMMED AFTERS 

7 3 

7 TWO MINUTES AFTERS 

7 * 

"CARPULS” HAS BEEN SAVED AS HEADER FILE. 
END. 

0.175 / 0.874 / 5 

Figure 3. CARPULS Created as Header File 


It is suggested, but not mandatory, that the first four items in all header files 
be SOC SEC #, DEPT, RECORD, and DATE, all with level-code zero. 

Nonrepetitive Use of HEADER. Once a file of headings has been created, 
HEADER need no longer be called for that file. The name of a particular 
header file, however, will be used regularly by other program segments to 
call up that file of headings. The user, therefore, must remember the precise 
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spelling of the department and record under consideration so/that the program 
can accurately recreate the appropriate header-file name ahd find the corres- 
ponding header file. J 

RESTART Option in HEADER. If while entering level codes and headings the 
user wishes to start over, he simply types RESTART, and the program will 
begin again without aborting. 

STORE Program 

The STORE program enables the user to enter data under a specific header file 
requested by the user. The program recreates the header-file name from the 
DEPT and RECORD names supplied by the user and uses it to find the header 
file associated with it. 

To call STORE, the user types EXEC, OLD, STORE (or just OLD, STORE if he 
has run any other program directly before STORE). In response to READY, he 
types RNH. 

Naming the Data File. The name of a data file is a string of one to seven char- 
acters given to a specific set of data records. Data file names already in use 
will ordinarily not be used. In the usual case, one wishes to add new records 
to an existing data file. One could call the set of new records a name such as 
NEWDATA. He could sort NEWDATA, if necessary, using SORTER and could 
then call MERGE to merge NEWDATA into the appropriate existing data file 
having such records. This procedure could be performed regularly, perhaps 
daily, as a standard updating technique. The file NEWDATA could be cleared 
by the user at the conclusion of MERGE by typing UNSAVE, NEWDATA. Thus 
the name NEWDATA would be available for repeated use in this context. 

Recalling the Proper Header File. The user's responses to DEPT? and REC- 
ORD? enable STORE to locate the appropriate header file. If misspelling of 
the department and/or record leads to the formation of a nonexistent header- 
file name, the user is so informed and is asked to enter valid data. 

Data Entry: Proper Format. Each data entry must be followed by an asterisk. 
For data items requiring more than one line, one hits the carriage return and 
waits until the end of the entire data item to affix the asterisk. Numerical data, 
except SOC SEC #, must be enclosed in parentheses to accommodate the ranging 
function of RETREVE (see the RETREVE program section). 

There are other musts for entering data. The date must be in DAY MONTH YR 1 ' 
form where DAY and YR are two-digit numbers and MONTH is the first three 
letters of the month, (e. g. , DATE ? 08 JUL 71''). Be sure to leave one 



space between DAY and MONTH and one between MONTH and YR. Also, the 
names must be in the format LAST, FIRST, MIDDLE*, with a space between the 
comma and the first name and between the first and middle names. Initials may 
be used for both the first and middle names. 

If Another Patient . When a new patient's data are being processed, the user 
replies YES (or Y), and the program returns to the first header entry of the 
header file being used (Figure 4). 

If No New Patient But Another Record . For a new record for the same patient, 
the user supplies the record, and a new header-file name is created. The cor- 
responding header file is then used to question the user, who enters data under 
the new record within the same department (Figure 5). 

If No More Patients and Records . The user is informed that his data file has 
been saved under the data file name given when he indicates he has no more 
patients and records to enter (Figure 4). If, however, his name was already 
used, he can either supply a new name for his file or replace the other data file 
with his by entering an asterisk. 

End of Program. At the end of the program, a message indicating that the data 
file has been saved under the proper name is printed. 

RESTART Option in STORE. Typing RESTART at any point during data entry 
commands the program to return to the beginning of the program. 

RETREVE Program 

The ability to recall information when it is wanted is the heart of any informa- 
tion storage and retrieval system. The RETREVE program (the seven-letter 
limitation precludes using "RETRIEVE") enables the user to define a search on 
very specific or very general information. To call the program, one types 
EXEC, OLD, RETREVE, and responds with RNH,M=13500 after READY appears. 

ED Items. Retrieval is conversational, consisting of machine interrogation and 
user response. In all retrievals, the user answers seven questions. The more 
specific the responses to the ID items, the more efficient and less costly the 
search. For instance, a search on a specific SOC SEC # yields all records for 
that person. The program does not have to "look at" the records of persons 
whose SOC SEC # differs from the one in question; it has only to compare the 
SOC SEC #'s and pass on if no match is found. 

CONDITION Question. If the search is defined by CONDITION (e.g. , AGE: 70-75*) , 
one might respond ALL’ to the four ED items. Boolean connectors provide great 
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EXEC. OLD# STORE 

READY. 

BMH 

PROGRAM* STORE DATE! 08/05/71 TIME! 15.17.48 


IF AT ANY TIME YOU WISH TO START OVER. ENTER "RESTART”. 


ENTER NAME YOU WISH TO CALL THIS DATA FILE* ? ACTIVE 


DEPT. 7 ADMITTING 
RECORD ? INITIAL 

THIS PROGRAM WILL USE ADMINIT AS HEADER FILE. 

BEGIN DATA INPUT. 

SOC SEC # 

DEPT 
RECORD 
DATE 
NAME 
AGE 
SEX 

ADDRESS 
PHONE 
COMMENTS 

ANOTHER PATIENT ? Y 
SOC SEC # 

DEPT 
RECORD 
DATE 
NAME 
AGE 
SEX 

ADDRESS 
PHONE 
COMMENTS 

ANOTHER PATIENT ? Y 
SOC SEC if 
DEPT 
RECORD 
DATE 
NAME 

age 
sex 

ADDRESS 
PHONE 
COMMENTS 


Figure 4. ACTIVE Created as Data File 


? 999-99-9999* 

ADMITTING 
INITIAL 
7 05 AUG 71* 

7 SABLE. ALEX V* 

7 C57) YRS* 

7 M* 

7 1015 VINE ST* 

7 9S7-65A3* 

7 EMERGENCY ROOM CASE* 


7 222-22-2282* 

ADMITTING 
INITIAL 
7 05 AUG 71* 

7 ABLE. ALICE A* 

7 C 227 YRS* 

7 F* 

7 BT 8. ROARING SPRINGS. PA* 
? 565-565_6» 

7 HAS NO INSURANCE* 


7 111-11-1111* 

ADMI TTING 
INITIAL 
7 05 AUG 71* 

7 CABLE. JAMES A* 

7 <35? YRS* 

7 M* 

7 155 BRIDGE RD. ST. LOUIS* 
7 222-4444* 

7 NEW PATIENT* 
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ANOTHER PATIENT 7 Y 


soc sec e 

7 222-22- 2223* 

DEPT 


ADMITTING 

RECORD 


INITIAL 

DATE 

7 

06 AUG 7U* 

NAME 

7 

ZABLE* MABLE C* 

AGE 

7 

( 41 •> YBS* 

SEX 

7 

K* 

ADDRESS 

7 

RIDGE HD* CHICAGO* 

PHONE 

7 

SSR- t P3A* 

COMMENTS 

7 

NONE * 


ANOTHER PATIENT 7 N 
ANOTHER RECORD 7 N 


•ACTIVE " HAS BEEN SAVED AS DATA KILE. 
STOP. 


0.728 / 5.823 / 56 


Figure 4 (Concluded). 

flexibility in specifying the CONDITION of the search. Parentheses can also be 
used to define a logical command. Figure 6 should give a feeling for the pos- 
sibilities in defining a search. 

ACTION Options. The response to ACTION defines the format of the data to be 
retrieved. The six options available are LIST, COUNT, TABULATE, TAB-SD, 
CROSSTAB, and COPY. 

LIST generates a copy of the data requested. 

COUNT gives the number of records fitting a given description. 

TABULATE generates the data asked for in WHAT according to the attributes in 
CONDITION. It also provides a count of all such cases. 

TAB-SD is identified with TABULATE but in addition generates statistical data 
such as mean, standard deviation, standard error, minimum data value, and 
maximum data value, as well as one and two standard-deviation confidence inter- 
vals . 

CROSSTAB generates a grid of data. 

The COPY, TABULATE, TAB-SD, and CROSSTAB options enable the user to 
specify information he wants to file under a new data file name. Ordinarily 
after information is retrieved and displayed for the user, it is not saved; it must 
be retrieved again if needed at a later date. 
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EXEC* OLD* STORE 


READY. 

HNH 

PROGRAM! STORE DATE! 08/05/71 TIME! 15.28.28 


IF AT ANY TIME YOU WISH TO START OVER* ENTER "RESTART". 


ENTER NAME YOU WISH TO CALL THIS DATA FILE! 7 NEVDATA 


DEPT. 7 CARDIOLOGY 
RECORD 7 HISTORY 

THIS PROGRAM WILL USE 

BEGIN DATA INPUT. 

SOC SEC if 

DEPT 

RECORD 

DATE 

•NAME 

EKG 

HT 

WT 

HEART ATTACKS 
HOW MANY 
DATE MOST RECENT 
AVG DURATION 
SEVERITY 

PRESENT CONDI T I ON 

ANOTHER PATIENT 7 Y 
SOO SEC ii 
DEPT 
RECORD 
DATE 

NAME 

EKG 

HT 

WT 

HEART ATTACKS 
HOW MANY 
DATE MOST RECENT 
AVG DURATION 
SEVERITY 

PRESENT CONDITION 

ANOTHER PATIENT 7 N 
ANOTHER RECORD 7 Y 


CARH1ST AS HEADER FILE. 


7 222-22-2222* , 
CARDIOLOGY 
HISTORY 
7 OS AUG 71* 

7 ABLE* ALICE A* 

7 NORMAL* 

7 (60) IN* 

7 Cl AO) LBS* 

7 «. 2) * 

7 22 MAR 71* 

7 <1) MINUTE* 

7 MILD* 

7 RESTING COMFORTABLY* 


7 999-99-9999* 
CARDIOLOGY 
HISTORY 
7 06 AUG 71* 

7 SABLE* ALEX V* 

7 ERRATIC* 

7 < 72) IN* 

7 <185) LBS* 

7 (3)* 

7 28 JUI, 71* 

7 (5) MINUTES* 

7 VERY SHARP PAINS* 
7 IN POOR SHAPE* 


Figure 5. NEWDATA Created as Data File 
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RECORD 7 PULSE 


THIS PROGRAM WILL USE CARPULS AS HEADER FILE. 
BEGIN DATA INPUT. 


SOC SEC * 

DEPT 
RECORD 
DATE 
NAME 
PULSE 
SITTING 
STANDING 
AFTER EXERCISE 
IMMED AFTER 
TWO MINUTES AFTER 


? 222-82-2282* 
CARDI OLOGY 
PULSE 

7 06 AUG 71* 

7 ABLE* ALICE A* 

7 (60)* 

? ( 62)* 

7 (QO)* 

? (75)* 


ANOTHER PATIENT 7 N 
ANOTHER RECORD ? N~ 


•VIEWDATA*' HAS BEEN SAVED AS DATA FILE. 
STOP. 


0.928 / 7.423 / 64 


Figure 5 (Concluded). 


COPY is commonly used to transfer a copy of a patient's record to another file 
name. For example, suppose there is a file called ACTIVE for current patients 
and one called INACTIV (just seven letters allowed) for past patients. One wants 
to transfer the records of a newly released patient from ACTIVE to INACTIV. 

He calls RETREVE and specifies the COPY option under ACTION for the pa- 
tients) involved. He attaches a name such as TRANSFER to this group of rec- 
ords and merges TRANSFER into the INACTIV file. TRANSFER could then be 
erased after the merge by typing UNSAVE, TRANSFER. 

One of the seven questions put to the user is CONDITION. CONDITION can 
specify numerical data intervals such as AGE: 20-29, AGE: 30-39, or AGE: 
40-49. WHAT specifies the kind of data one wishes to count according to CON- 
DITION. For instance, if WHAT is SEX:M OR SEX:F, the output is a set of six 
numbers in grid form indicating the number of 20 to 29 year-old, 30 to 39 year- 
old, and 40 to 49 year-old males and females. 

For research purposes also, it is often desirable to be able to work with dupli- 
cated data records. In fact, the entire set of records in the system could be 
duplicated in this manner. 
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PCEC . OLD. BEIREVE 


READY. 

RMH.M-1350Q 

PROGRAM* RETRIEVE DATE* 08/06/71 TIME* 10.88.45 


ENTER NAME OF DATA FILE l ? ACTIVE 


SOC SEC # 
DEPT 
RECORD 
DATE 

CONDITIONS 

ACTION 

WHAT 

COUNT IS 
***** THIS 
SOC SEC # 
DEPT 
RECORD 
DATE 

CONDITIONS 

ACTION 

WAT 


7 AIL* 

7 ALL* 

7 ALL* 

7 Al l * 

7 All* 

7 COUNT* 

7 ALL* 

7 

RETRIEVAL TOOK .333 SECONDS 
7 1 I I- 1 I- I I 1 1* 

7 ALL* 

7 ALL* 

7 All* 

7 ALL* 

7 LIST* 

7 ALL* 


lu-ii-ini 

ADMITTING 5AUG7 1 


NAME 

AGE 

SEX 

ADDRESS 

PHONE 

COMMENTS 

********** 


CABLE. JAMES A 
(35) YRS 
M 

155 BRIDGE RD. ST. 

888-4444 

NEW PATIENT 


COUNT IS 1 

***** THIS RETRIEVAL TOOK .487 SECONDS 
SOC SEC # 7 1 1 1 -LL^LLLJL* 


DEPT 

RECORD 

DATE 

CONDITIONS 


7 IN IT 1 AL* 
7 ALL* 

7 ALL* 


ACTION 7 LIST* 

WHAT 7 NAME AND COMMENTS* 


LOUI S 


111 - 11-1111 

ADMI TTI NG 5AUG71 


NAME CABLE. JAMES A 

COMMENTS NEW PATIENT 

********** 

COUNT I S 1 

***** THIS RETRIEVAL TOOK .410 SECONDS 


SOC SEC 0 
DEPT 
RECORD 
DATE 

CONDITIONS 

ACTION 

WHAT 


7 ALL* 

7 ALL* 

7 ALL* 

7 ALL* 

7 AG El 80 TO 60* 
7 TABULATE* 

7 NAME AND AGE* 


Figure 6. All Options in RETREVE 
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NAME 

AGE 

111-11-1 5AUG71 

CABLE. 

35 

222-22-2 5AUG71 

ABLE. A 

22 

222-22-2 6AUG71 

ZABLE. 

41 

999-99-9 5AUG71 

SABLE. 

57 

COUNT I S 4 

DID YOU COPY OR 

TAB ANY INFO YOU WANT ’ 

***** THIS RETRIEVAL TOOK .420 SECOND: 

SOC SEC * 

7 -ALL* 


dept 

7 .ALL* 


RECORD 

? Alt * 


DATE 

7 ALL* 


CONDITIONS 

T AfiPl PA 

TO AO* 

ACTION 

7 TAB?SD* 


WHAT 

7 NAME AND 

AGE* 


NAME 

AGE 

111-11-1 5AUG71 

CABLE. 

35 

222-22-2 5AUG71 

ABLE. A 

22 

222-22-2 6AUG71 

ZABLE. 

41 

999-99-9 5AUG71 

SABLE. 

57 

NO 


4 

MEAN 


38 

SD 


12 

SE 


6 

MAX 


57 

MIN 


22 


MEAN 

MEAN 


+ SSD 
- 2SD 


63 

13 


7 NO. 


DID YOU COPY OP TAB ANY INFO YOU WANT TO SAVEt ? Jifl. 


***** THIS RETRIEVAL 
SOC SEC # 

DEPT 
RECORD 
DATE 

CONDITIONS 
ACTION 
WHAT 


TOOK .481 SECONDS 
? -ALL* 

? ALL* 

7 ALL* . 

? ALL* 

? AGEt-gfl- -TO g9 -OR AGLEl 30 TO 39 OP AGEi 40 -TO 49* 
7 -SEXt M AND SEX» F* 


SEX 


SEX 


AGE 20 
AGE 30 
AGE 40 
COUNT IS 


0- 

0- 

0- 


29. 

39. 

49. 


- 0 . 

0 

1 

0 


0. - o. 

1 
0 
1 

.401 SECONDS 


***** THIS RETRIEVAL TOOK 
SOC SEC # 7 ALL* 

DEPT 7 ALL* 

RECORD 7 ALL* 

DATE 7 

CONDITIONS 7 

ACTION 7 

WHAT 7 ALL* 

COUNT IS 4 

DID YOU COPY OR TAB ANY INFO YOU WANT TO SAVE* 7 
WHAT NAME DO YOU WANT TO CALL IT« 7 TPANSFP 
TRANSFR HAS BEEN SAVED. 

STOP. 


05 AUG 71* 
ALL* 

■COPY* 


YES 


A. 131 / 57.833 / 1092 


Figure 6 (Concluded). 
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WHAT Question. The seventh question, WHAT, can be used to specify what to 
LIST (e. g. , ALL* or AGE AND HT*), or it can be used to specify the horizontal 
axis under TABULATE, CROSSTAB, and TAB-SD. 

Format for Requesting Data. An asterisk must follow the response to each of 
the seven questions. Since spacing is important, one must use the identical 
spacing in RETREVE that was used in STORE while entering data such as NAME 
and DATE. 

Data Not There. If a search is specified by CONDITION and no existing data 
matches this specification (see Figure 6 \ the program will respond NONE OF 
THE SPECIFIED RECORDS THE INFO. If a search is conducted on a non-exis- 
tent SOC SEC #, DEPT, RECORD, or DATE, the program response is SPECI- 
FIED RECORD IS NOT IN FILE. Thus, the system does provide a definite re- 
sponse when no data is found to match a request. 

RESTA RT Option in RETREVE. If for any reason the user wishes to restart a 
search, he simply types RESTART. 

Multiple Retrieval of Data. Once the user has supplied the name of the data file 
he wishes to search, he may conduct as many searches as he wishes. The com- 
mand END OF REQUEST signals that he is finished. However, the user may 
wish to search a data file different from the original one. To do this, he sim- 
ply types NEW FILE ; the program will request the name of the other file , and 
additional searches can be performed. Again, only when the user supplies 
END OF REQUEST will the running of this program terminate. 

UPDATE Program 


The UPDATE program alters data files by (1) changing an entry in a data rec- 
ord, (2) adding to a data record, and/or (3) deleting a heading and its corres- 
ponding data (or deleting an entire record or records). To call UPDATE, one 
types EXEC, OLD, UPDATE, and then RNH,M=11000 after READY appears. 

ID Items . As in RETREVE, the user specifies what he wishes to update by 
responding to seven questions. The ID responses should be obvious, depending 
on need. The user may answer with ALL* or with specifics. 

ACTION, WHAT, and TO. ACTION maybe CHANGE*, ADD*, or DELETE* 
(see Figure 7). hi the first case, WHAT and TO are asked in that order. If 
ADD* is used, TO and WHAT are asked in that order. For DELETE^, only 
WHAT is asked. If ACTION is CHANGE*, WHAT must be answered by a spe- 
cific heading followed by a colon, followed by the precise string of characters 
that presently occurs in that data field. The response to TO is simply the new 
data entry (Figure 7). For ADD, the user follows the same procedure. 
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. BtECj OLD * UPDATE 


BEADY. 

SMH.MM 1000 

PROGRAM* UPDATE DATE* 08/06/71 TIME* 10.45.15 


DO YOU WANT TO MAKE MORE THAN ONE CHANGE 7 YES 
ENTER THE NAME OF THE FILE TO BE UPDATE 7 ACTIVE 


SOC SEC 4 

7 222-22-2222* 

DEPT 

7 ADMITTING* 

RECORD 

7 INITIAL* 

DATE 

7 05 AUG 71* 

ACTION 

7 CHANGE* 

WHAT 

7 ADDRESS* RT R. ROARING SPRINGS, da* 

TO 

7 RT 7. FALLING ROCK. VA* 


MATCH ON 222-22-822 ADMITTING INITIAL 


? ggg-gg-gaaa 
7 ADMITTING* 
? I NTT! AL* 

7 06 AUG 71* 
? DELETE* 

7 COMMENTS* 
ADMITTING INITIAL 


SOC SEC 4 

DEPT 

RECORD 

DATE 

ACTION 

WAT 

MATCH ON 222-22-222 


SOC SEC 

DEPT 

RECORD 

DATE 

ACTION 

TO 

WHAT 


7 ADMITTING* 

7 JNITI AL* 

7 05 AUG 71* 

7 ADD* 

7 COMMENTS* 

7 ZLD BEING TRANSFERRED* 


MATCH ON 111-11-111 ADMITTING INITIAL 


SOC SEC # ? DONE* 

STOP. 


1.406 / 15.465 / 374 


Figure 7. The Three UPDATE Options 


RESTART Option in UPDATE. If the user wishes to begin again, he types RE- 
START*. (Note: In UPDATE only , an asterisk must be included in this com- 
mand. ) 
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Updating of Additional Data Files. To update additional data files, the user 
enters NEW FILE, and the system will request the name of the file. The user 
continues by updating records in the new file. 

When Finished Updating . When the updating is completed, the user enters 
DONE* to end the program. All changes will have been recorded on the per- 
manent records . 

SORTER Program 


The SORTER program arranges records according to priorities given to the 
four ID items by the user. These priorities are indicated by typing 1,2,3, or 
4 after each question mark, with no number used more than once. One also 
specifies if the records are to be sorted into ascending (A) or descending (D) 
order according to these priorities. 

This segment is used to sort two data files prior to their merger and to enable 
the user to list data in a given order, i. e. , by SOC SEC #, by alphabetical 
order of DEPT or RECORD, or by DATE. Observe that grouping of data rec- 
ords by DEPT and RECORD always takes precedence over grouping by SOC 
SEC # or DATE. 

The user types EXEC, OLD, SORTER to call the program, and responds with 
RNH after the teletype communicates READY (Figures 8 and 9). 

MERGE Program 


The MERGE program merges two sorted data files (see the STORE program 
section, which discusses merging two data files). New records cannot be 
placed into an existing permanent data file directly. They must first be 
placed into a new data file which is then merged with (i. e. , into) the related 
permanent file. The user can either save or erase this new data file. 

In Figure 10, the response to the first question is the name of the permanent 
file: ACTIVE for current patients. NEWDATA is a file of records for new 
patients. Both files have been sorted into ascending (A) order. The user must 
again specify the priority of the ID items, as in SORTER. In the example, the 
user retains the merged data files under the name ACTIVE although a third 
file name could also have been given; To call MERGE, the user types EXEC, 
OLD, MERGE, and then types RNH, M=9000 after READY appears. 
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EXEC* OLD, SORTER 


READY. 

HNH 

PROGRAM! SORTER DATE! 08/05/71 TIME! 15. A3. 19 


DO YOU NEED OPERATING INSTRUCTIONS ? N 

ENTER NAME OF THE DATA FILE TO BE SORTED ? ACTIVE 

WILL THE DATA FILE BE SORTED INTO ASCENDING (A) OR 
DESCENDING <D> SEQUENCE 7 A 

ENTER SORTING SEQUENCE HERE 
? 1 
7 3 
7 4 
7 2 

SORT COMPLETED. 

YOU HAVE SORTED 4 DATA RECORDS. 

STOP. 

0.632 ✓ 5.055 / 104 

Figure 8. ACTIVE is Sorted 


EXEC. OLD. SORTER 

READY. 

HNH 

PROGRAM! SORTER DATE! 08/05/71 TIME! 15.45.38 


DO YOU NEED OPERATING INSTRUCTIONS 7 N 

ENTER NAME OF THE DATA FILE TO BE SORTED 7 NEW DATA 

WILL THE DATA FILE BE SORTED INTO ASCENDING CA) OR 
DESCENDING <D) SEQUENCE 7 A 

ENTER SORTING SEQUENCE HERE 

? L 

7 3 
7 a 
7 2 

SORT COMPLETED. 

YOU HAVE SORTED 3 DATA RECORDS. \ 

STOP. 

0.552 / 4.415 / 104 

Figure 9. NEWDATA is Sorted 
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EXEC* OLD* MERGE 


READY* 

am*M»9000 

PROGRAM! MERGE DATE! 08/05/71 TIME! 15.47*47 


ENTER NAME OF THE FIRST FILE TO BE MERGED! 7 ACTIVE 
ENTER NAME OF THE SECOND FILE TO BE MERGED! 7 NEWDATA 


ARE THESE FILES IN ASCENDING (A) OR DESCENDING (D) SEQUENCE 7 A 
WHAT IS THE ORDER OF THE MERGE KEYS 7 ANSWER THE FOUR 
QUESTION MARKS WITH A 1*2.3* OR 4. 

7 I 
7 3 
7 ! 

7 2 

7 DATA RECORDS HAVE BEEN MERGED. 

UNDER WHAT NAME SHOULD ALL OF THE MERGED RECORDS NOW BE FOUND 7 ACTIVE 

FILE ALREADY PERMANENT. ENTER A NEW FILE NAME OR 

ENTER ’•REPLACE" TO REPLACE CURRENT PERMANENT FILE! 7 REPLACE 

ACTIVE HAS BEEN REPLACED AS MERGED FILE. 

STOP. 


0.684 / 6.155 / 135 

Figure 10. ACTIVE and NEWDATA are Merged Under the File Name ACTIVE 
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APPENDIX: LISTING OF THE SIX PROGRAMS IN MIMS 1 


An introductory remark to several of these programs states that Paul Simmons is 
working at United Computing Systems, Inc., and Ronald Schwarz is with GSFC. 
This was true when these programs were developed. However, please note that 
Paul Simmons is currently working at Computing and Software, Inc., and Ronald 
Schwarz is now with Federal City College. 
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** "HEADER" — CREATES MASTER HEADER RECORD FOR MIMS SYSTEM 
07/30/71. 08.39.22. 


00100C THIS PROGRAM WAS RE-DESIGNED AND DEVELOPED BY PAUL SIMMONS, 

001 IOC UNITED COMPUTING SYSTEMS, INC., AND RONALD SCHWARZ, GODDARD 
00120C SPACE FLIGHT CENTER, JULY, 1971. 

00130C 

00140 PROGRAM HEADER ( INPUT, OUTPUT, TAPE4). 

00150 DIMENSION IF0RM(9 ),KODE( 1 60 ) ,LCQ( 1 60), LHEAD( 3, 1 60) 

001 60C 

00170C CARRIAGE CONTROL TO PRODUCE THE HIERARCH I AL EFFECT RELATED 
00180C TO LEVEL CODES WHEN HEADING INPUT IS REQUESTED. 

00190C 

00200 DATA I F0RM/5HC 1X« ) , 5H( 2X* >, 5H( 3Xt ), 5H( 4X» ), 5HC 5Xt ), 

00210+5H( 6X» ),5H(7Xt),5H<8X» ),5HC9Xt )/ 

00220 CALL CLOCK(IX) 

00230 CALL DATER(IS) 

00240 PRINT 33, IS, IX 

00250 3 PRINT, *THIS PROGRAM WILL BUILD A FILE OF LEVEL CODES AND* 

00260 PRINT, *HEADINGS. DO YOU NEED OPERATING INSTRUCTIONS*, 

00270 10 READ 200, IYORN 

00280 IF ( IYORN. EQ.1HN) GO TO 30 

00290 IF C IYORN.EQ. 1HY) GO TO 20 

00300 PRINT, *A SIMPLE YES OR NO WILL DO.*, 

003 IQ GO TO 00010 
00320C 

00330C OPERATING INSTRUCTIONS. 

00340C 

00350 20 PRINT, /,*0K, HERE* S HOW IT'S DONE. WHEN THE FIRST QUESTION* 
00360 PRINT, *MARK APPEARS, ENTER A LEVEL CODE (0-9). WHEN THE NEXT* 
00370 PRINT, * QUEST I ON MARK APPEARS , ENTER THE HEADING (FROM 1-24* 
00380 PRINT, * CHARACTERS) THAT CORRESPONDS TO YOUR LEVEL CODE. FOR* 
00390 PRINT, *HEADINGS THAT WILL NORMALLY HAVE DATA FOLLOWING THEM* 
00400 PRINT, * ENTER A COLON AFTER THE HEADING. FOR BLIND HEADINGS* 
00410 PRINT, *( THOSE WHICH WILL -NOT HAVE DATA FOLLOWING THEM) DO NOT* 
00420 PRINT, * ENTER THE COLON.* 

00430 PRINT, /,*REPEAT THIS PROCESS UNTIL YOU HAVE NO MORE HEADINGS- THEN 
(CONT'D) * 

00440 PRINT, * ENTER AN ASTERISK TO TERMINATE THE PROGRAM.* 

00450 PRINT, *IF YOU WISH TO ENTER A STOP SKIP CODE, ENTER AN "S"* 

00460 PRINT, * INSTEAD OF A LEVEL CODE. THEN ENTER THE LEVEL CODE AND * 
OO470 PRINT, +HEADING AS USUAL FOLLOWING THE NEXT TWO QUESTION MARKS.* 
00480 PRINT, *IF AT ANY TIME YOU WANT TO START OVER, ENTER "RESTART".* 
00490 30 PRINT, /,*ENTER 3 LETTERS OF DEPT. NAME AND 4 LETTERS OF RECORD 
(CONT'D) * 

00500 PRINT,* ENTER FEWER IF 7 ARE NOT AVAILABLE*, 

00510 READ 77, I FILE 

00520 PRINT, /,*BEGIN DATA INPUT.*,/ 

00530C 

00 540 C VARIABLE I IS COUNTER FOR NUMBER OF HEADINGS. 

00550C 
00560 1=0 

00570 40 I = I + l 
00580 KODE( I ) = 55B 
00590 50 READ 200, LCQCI) 
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** ••HEADER" — CREATES MASTER HEADER RECORD FOR MIMS SYSTEM 
07/30/71. 08.39.22. 


00600 IF (LCQC I ) • EQ. 7HRESTART) GO TO 3 
00610 IF CLCQC I ) .EQ. 1HS) GO TO 5 
00620 IF <LCQ< I ) • EQ. 1H* ) GO TO 60 
00630C 

00640C CONVERT LEVEL CODE FROM A1 FORMAT TO II FORMAT. 

00 650 C 

00660 LCQC 1 > = CISHIFT CLCQ(I),-54) - 33B> .AND. 77B 

00670 IF C CLCQC I ) .LT.O ) . OR. CLCQC I).GT.9)) GO TO 99 

00680 GO TO 00025 

00690 5 KODECI) = 64B 

00700 GO TO 00050 

007 IOC 

00720C DETERMINE WHICH FORMAT STATEMENT (CARRIAGE CONTROL) 

00730C CORRESPONDS ' TO THE LEVEL CODE FOR THIS HEADING. 

007 40 C 

00750 25 NN = LCQC I ) + 1 
00760 M = I FORMCNN) 

00770 PRINT M 

00780 READ 240, CLHEADC J, I ), J=1 , 3) 

00790 IF CLHEADC 1, I ) .EQ. 7HRESTART) GO TO 3 
00800 GO TO 00040 

00810 99 PRINT, * UNACCEPTABLE LEVEL CODE, TRY AGAIN* 

00820 GO TO 00050 
00830 60 I = I - 1 
00840C 

00850C WRITE ICTHE NUMBER OF HEADINGS), KODEC I ) CTHE STOP SKIP 
00860C CODES), LCQC I ) ( THE LEVEL CODES), AND LHEADC L, I ) ,L= 1 , 3 ) C THE 
00870C HEADING DATA) TO FILE #4. 

00880C 

00890 WRITE C4,2I0) I 
00900 DO 80 K= 1,1 

00910 WRITE C 4, 220 ) KODEC K),LCQCK), C LHEADC L,K),L= 1,3) 

00920 80 CONTINUE 
009 30 C 

00940C ATTEMPT TO SAVE NEWLY CREATED HEADER FILE. 

00950C 

00960 84 CALL PFURC 3HSAV, 4, I FILE, 0, I STA) 

00970 I OP = 5H SAVED 
00980C 

00990C IF FILE ALREADY EXISTS, SAVE UNDER NEW NAME, OR REPLACE 
01000C EXISTING FILE. 

01010C 

01020 IF CISTA .EQ. 4) GO TO 44 
01030 IF CISTA .EQ. 0) GO TO 92 

01040 44 PRINT, *FILE ALREADY PERMANENT. ENTER NEW FILENAME OR* 

01050 PRINT, *ENTER AN ASTERISK TO REPLACE CURRENT PERMANENT FILE:*, 

01060 I FILES = I FILE 

01070 READ 77, IFILE 

01080 IF C IFILE .EQ. IH*) GO TO 66 

01090C 

01100C FILE IS TO BE SAVED UNDER ANOTHER FILE NAME. 

01H0C 
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** "HEADER” — CREATES MASTER HEADER RECORD FOR MIMS SYSTEM 
07/30/71. 08.39.22. 


01120 GO TO 00084 
01130 66 I FILE = IFILES 
01140C 

0U50C FILE IS TO BE REPLACED. 

01160C 

01170 CALL PFUR< 3HREP.4. I FILE. 0. ISTA) 

01180 10P ■ 8HREPLACED 
01190 92 PRINT 88.IFILE.I0P 
01200C 

01210C FORMAT STATEMENTS. 

01220C 

01230 33 FORMAT (/*PR0GRAM« HEADER*. 4X.*DATE**.A9,4X.*TIME**.A9,///) 
01240 77 FORMAT <A7> 

01250 88 F0RMAT(*"*.A7.*" HAS BEEN *.A8.* AS HEADER FILE.* > 

01260 200 FORMAT <A1> 

01270 210 FORMAT (IX. 13) 

01280 220 FORMAT < IX.02. IX. 1 1. IX. 3(A10) > 

01290 240 FORMAT (3CA10)) 

01300 250 FORMAT (A7> 

01310 END 


---THE E N D - - - 
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** "STORE" — CREATES DATA FILE ACCORDING TO HEADER FORMAT 
07/30/71. 09.57.12. 


00100C THIS PROGRAM WAS RE-DESIGNED AND DEVELOPED BY PAUL SIMMONS* 

001 IOC' UNITED COMPUTING SYSTEMS* INC.* AND RONALD SCHWARZ, GODDARD 
00120C SPACE FLIGHT CENTER* JULY* 1971. 

00130C 

00140 PROGRAM STORE < INPUT, OUTPUT* TAPE7* TAPES* TAPE9) 

00150 COMMON N* I AND* I OR* IBK* I TAG* IDt8*4), LHEADt 3*160) 

00160 DIMENSION LCQt 1 60), IPNTt 1 60 )*KODE( 1 60 )* IDEPTS(4), IRECSt 4), 

00170+ IANS<7>* JANS< 1000) 

00180 CALL CLOCK< IX) 

00190 CALL DATERt IS) 

00200 PRINT 79, IS*.IX 

00210 79 FORMAT C/*PROG RAM: STORE** 4X* *DATE: **A9* 4X**TIME:**A9, ///) 

00220 PRINT* /**IF AT ANY TIME YOU WISH TO START OVER* ENTER "RESTART".* 
00230 PRINT* / 

00 240 C NRD = NUMBER OF WORDS THAT CAN BE READ C4 FOR TELETYPE OR 
00250C DATAPOINT 3300 CRT ETC) 

00260 4 NRD = 5 

00270 IBK = 055000000000000000000 
00280 TWOMSK * 7777B 
00290 MASK * 77B 

00300 KOLN » 063620000000000000000 
00310 ISEVN = 000007777777777777777 
00320 I AND = 077000000000000000000 
00330 I OR = .NOT. I AND 

00340 PRINT* *EN TER NAME YOU WISH TO CALL THIS DATA FILE:** 

00350 READ 78* I FILE 
00360 78 FORMAT (A7 ) 

00370 PRINT,/*/ 

00380 19 PRINT* *DEPT.*, 

00390 READ 550* C IDEPTSt I)*I=1»4) 

00400 5 PRINT* *RECORD*, 

00410 READ 550* C IRECSC I )* 1 = 1 * 4) 

00420 PRINT** * 

00430 93 FORMAT C * TH I S PROGRAM WILL USE *,A7,* AS HEADER FILE.*) 

00440 GO TO 00013 

00450 13 IDEPT = IDEPTS< 1 ) .AND. 777777 OOOOOOOOOOOOOOB 

00460 IREC = IRECS< 1 ) . AND.77777777000000000000B 

00470 NAME = IDEPT. AND. 77000000000000000000B 

00480 KKK = I SHI FT< I DEPT* -48 ) . AND. 77 B 

00490 IF (KKK.EQ.55B) GO TO 310 

00500 NAME = I DEPT. AND. 77770000000000000000B 

00510 KKK = I SHI FT C I DEPT* -42 ) .AND. 77 B 

00520 IF <KKK.EQ. 55B) GO TO 315 

00530 NAME = < I DEPT. AND. 77777700000000000000B) . OR. I SHIFTt IREC* - 1 8 ) 

00540 GO TO 320 

00550 310 NAME = NAME. OR. ISHIFTt IREC*-6) 

00560 GO TO 320 

00570 315 NAME = NAME. OR. ISHIFTt IREC*-12) 

00580 320 CALL PFURt 3HRET*7*NAME*0* ISTA) 

00590 IFt ISTA.EQ.5) GO TO 666 

00600 PRINT 93*NAME 

00610 PRINT, /,*BEGIN DATA INPUT.**/ 
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** ••STORE" — CREATES DATA FILE ACCORDING TO HEADER FORMAT 
07/30/71. 09.57.12. 


00620 10 DO 15 J= 1.4 
00630 15 IPNTCJ) = 0 
00640 JJ = 5 
00650 II = 1 
00660 IDD = 2Ht 3 

00670C SET FIRST WORD OF 4 I D ANSWERS TO S3 

00680 DO 20 J=l,4 

00690 20 IDC 1, J) = IDD 

00700 IBLNK = 10H 

007 IOC BLANK FINAL ANSWER ARRAY 

00720 DO 22 Ja 1,1000 

00730 22 JANSCJ) = IBLNK 

00740 DO 23 J=l,160 

00750 23 LHEADC 1, J) = IBLNK 

00760 IANDEX = 0 

00770 IPT = 1 

007 80C READ HEADER FILE 

00790 25 READ (7,510) IQNDEX 

00800 DO 30 K»l, IQNDEX 

00810 30 READ (7,630) KODE(K),LCQ(K>, ( LHEADC L,K),L=1, 3) 
00820 DO 47 N=l,4 

00830C ELIMINATE COLON IF THERE IS ONE 
00840 CALL ECOLON 
00850 47 CONTINUE 

00860 CALL PRNT (LCQC 1 ),LHEAD( l, 1 ),LHEAD(2, 1 ),LHEAD(3, 1) ) 
00870 READ 550, C IDCL, 1 ),L«2, 5) 

00880 51 IF (ID(2, 1 ).EQ.7HRE START) GO TO 5 

00890 CALL PRNT (LCQ( 2) ,LHEAD( 1, 2) ,LHEAD( 2, 2) ,LHEAD( 3, 2) ) 
00900 ID( 2, 2) = IDEPTS(l) 

00910 I D( 3, 2) = IDEPTSC 2) 

00920 ID(4, 2) = IDEPTS( 3) 

00930 PRINT 500, ( IDEPTS( I), I®1, 3) 

00940 CALL PRNT CLCQC3), LHEAD( 1, 3),LHEAD( 2, 3),LHEAD( 3, 3) ) 
00950 ID( 2, 3) = IRECS(l) 

00960 IDO, 3) = IRECSC 2) 

00970 ID(4,3) a IRECSC 3) 

00980 PRINT 500* ( IRECSC I ),I=1,3) 

00990 DO 55 L=2,8 
01000 DO 55 J=l,3 
01010 CALL ETERMdDCL, J),MSWIT) 

01020 55 CONTINUE 

01030 CALL PRNT (LCQC 4), LHEADC 1., 4) , LHEADC 2, 4), LHEADC 3,4) ) 
01040C HANDLE DATE 
01050 CALL DATE 
01060C 

01070C GUTS OF THE PROGRAM 

01080C 

01090 N = 5 

01 100 60 Mai , 

OHIO ITAG = 0 

01120 CALL ECOLON 

01130 IF C ITAG .EQ. 1) GO TO 65 



** ••STORE" — CREATES DATA FILE ACCORDIMG TO HEADER FORMAT 
07/30/71. 09.57.12. 


01140 CALL PRNT CLCQCN) .LHEADC 1 .N ) . LHEADC 2.N ) .LHEADC 3.N ) ) 
01150 PRINT. * * 

01160 IPNTCJJ) = 0 
01170 JJ = JJ + 1 
01180 GO TO 00125 

01190 65 CALL PRNT CLCQCN). LHEADC 1 . N) . LHEADC 2. N). LHEADC 3.N ) ) 
01200 71 READ 550. C I ANSI L) .L= 1 .NRD) 

01210 74 I F< I ANSI 1 ) .EQ. 7HRESTART) GO TO 5 
01220 IF C I ANSI 1 ) .NE. 5HSKIP* ) GO TO 75 
01230 72 LHEADC l.N) = IBLNK 
01240 N = N+l 

01250 IF CN .GT. IQNDEX) GO TO 126 
01260 IF CKODECN) .NE. 64B) GO TO 72 
01270 GO TO 00060 

01280 75 IF C < IANSC 1 ) .EQ. IBLNK) .AND. CM .EQ. 1>> GO TO 76 

01290 GO TO 00077 

01300 76 LHEADC l.N) = IBLNK 

01310 GO TO 00125 

01320C IF NOT FIRST LINE OF ANSWER GO TO 100 
01330 77 IF CM .NE. 1) GO TO 100 
01340 NWD = IANSC 1) .AND. I AND 

01350 IF CNWD .EQ. 051000000000000000000) GO TO 85 v 

01360 IPAD = KOLN 

01370 DO 80 K=1,NRD 

01380 NUSFT = IANSCK) .AND. TWOMSK 

01390 IANSCK) = I SHI FTC I ANSC K) . - 1 2) 

01400 NUSFT * I SHI FTC NUSFT. 48 ) 

01410 IANSCK) = IANSCK) .AND. ISEVN 
01420 IANSCK) = IANSCK) .OR. IPAD 
01430 80 IPAD = NUSFT 
01440 GO TO 00100 

01450C ANSWER IS A NUMBER ENCLOSED IN PARENS 
01460 85 ICHANG = 062000000000000000000 
01470 IANSC 1 ) = IANSC 1) .AND. IOR 
01480 IANSC 1) = IANSC 1) .OR. ICHANG 
01490 MZ = 1 

01500 ICHANG = 063000000000000000000 
01510 90 I TAG = 0 
01520 DO 95 K=l. 10 

01530 IANSCMZ) = I SHI FTC IANSCMZ ) . 6) 

01540 NUSFT a IANSCMZ) .AND. I AND 

01550 IF CNUSFT .NE. 052000000000000000000) GO TO 95 

01560 IANSCMZ) = IANSCMZ) .AND. IOR 

01570 IANSCMZ) = IANSCMZ) .OR. ICHANG 

01580 I TAG « 1 

01590 95 CONTINUE 

01600 IF CITAG .NE. 0) GO TO 100 

01610 MZ = MZ+1 

01620 GO TO 00090 

01630C ELIMINATE TERMINATOR IF THERE IS ONE 
01640 100 DO 105 K= 1 .NRD 
01650 MSWIT = 0 
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** "STORE” — CREATES DATA FILE ACCORDING TO HEADER FORMAT 
07/30/71. 09.57.12. 


01660 CALL ETERMC IANS(K).MSWIT) 

01670 IF ( IANS(K) .EQ. IBLNK .AND. MSWIT .EQ. 1) GO TO 120 
01680C PUT ANSWER IN FINAL ANSWER ARRAY 
01690 JAN S(II) = I ANSOO 
01700 IANS(K)=IBLNK * 

01710 II = II + l 

01720 M = M+l 

01730 IANDEX = IANDEX+1 

01740 IF CMSWIT.EO.l) GO TO 120 

01750 105 CONTINUE 

01760 PRINT 620 

01770 GO TO 00071 

01780 120 IPNT(JJ) = IPT 

01790 IPT = IPT + M - 1 

01800 JJ = JJ + 1 

01810 125 N = N + 1 

01820 IF (N .LE. IQNDEX) GO TO 60 

01830 126 CONTINUE 

01840C 

01850C RESET LHEAD ARRAY FOR BLANK HEADINGS 
01860 I = 1 
01870 K = 2 

01880 127 IF (LHEAD(l.I) .NE. IBLNK) GO TO 130 

01890 DO 128 M= 1.3 

01900 128 LHEAD(M.I) a LHEAD(M. K) 

01910 LCQ(I) = LCQ(K) 

01920 LHEADO.K) = IBLNK 
01930 129 K = K+l 

01940 IF <K .GT. IQNDEX) GO TO 131 

01950 JUICE a l 

01960 GO TO 00127 

01970 I = 1+1 

01980 GO TO 00129 

01990 130 IF < JUICE .NE. 1) K = K+l 
02000 JUICE = 0 
02010 I = 1+1 

02020 IF <K .LE. IQNDEX) GO TO 127 

02030 131 DO 132 J=l. IQNDEX 

02040 IF CLHEADC 1 . J) .EQ. IBLNK) GO TO 133 

02050 132 CONTINUE 

02060 GO TO 00134 

02070 133 IQNDEX = J - 1 

02080 134 CONTINUE 

02090C 

02100C 

021 IOC WRITE OUTPUT 

02120 WRITE (8.560) I QNDEX. I ANDEX 

02130 DO 135 Ja 1.4 

02140 135 WRITE (8.530) ( I D( I . J) . I =1 . 7 ) 

02150 DO 140 M=l» IQNDEX 

02160 140 WRITE (8.530) (LHEAD(L.M).L=1.3) 

02170 IF ( IQNDEX. LE. 65) GO TO 145 
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02180 WRITE (8.520) (LCQ(K),K*=1, 65) 

02190 WRITE (8,520) (LCQ(K),K=66, IQNDEX) 

02200 GO TO 150 

02210 145 WRITE (8,520) (LCQ(K),K=1, IQNDEX) 

02220 150 MPT = 22 

02230 M * 1 

02240 155 N = M + 21 

02250 IF (IQNDEX - MPT) 165,165,160 

02260 160 WRITE (8,590) ( IPNT(K) ,K=M,N) 

02270 M = N + 1 
02280 MPT = MPT + 22 
02290 GO TO 00155 

02300 165 WRITE (8,590) (IPNT (K), K=M, IQNDEX) 

02310 J = 1 

02320C COMPUTE HOW MANY LINES IT TAKES TO WRITE DATA 

02330 IZAN = ( IANDEX/6) + 1 

02340 I PAN = (IZAN - 1)*6 

02350 IF (IPAN .EQ. IANDEX) IZAN = IZAN-1 

02360 DO 170 M = 1,IZAN 

02370 K = J + 5 

02380 WRITE (8,530) ( UANS( I ), 1= J,K) 

02390 170 J=J+6 
02400 REWIND 7 

02410 PRINT, /,*ANOTHER PATIENT*, 

02420 175 READ 600, ICONT 

02430 IF ( ICONT. EQ. IHN) GO TO 180 

02440 IF ( ICONT. EQ. 1HY) GO TO 10 

02450 PRINT, *A SIMPLE YES OR NO, PLEASE* 

02460 GO TO 175 

02470 180 PRINT, +ANOTHER RECORD*, 

02480 185 READ 600, ICONT 
02490 PRINT,/ 

02500 IF (ICONT.EQ. IHN) GO TO 190 
02510 IF (ICONT. gQ. 1HY) GO TO 5 

02520 PRINT, *PLEASE ANSWER YES OR NO* . 

02530 GO TO 00185 

02540 190 CALL PFUR( 3HSAV, 8, IFILE.O, I STA) 

02550 1 0P= 5HSAVED 

02560 IF (ISTA .EQ. 4) GO TO 44 

02570 IF (ISTA .EQ. 0) GO TO 92 

02580 44 PRINT, *FILE ALREADY PERMANENT. ENTER NEW FILENAME OR* 

02590 PRINT, *ENTER ASTERISK TO REPLACE CURRENT PERMANENT FILE.*, 

02600 I FILES= I FILE 

02610 READ 78,IFILE 

02620 IF ( I FILE .EQ. 1H*) GO TO 66 

02630 GO TO 190 

02640 66 I FILE= I FILES 

02650 CALL PFUR( 3HREP, 8, I FILE,0, I STA) 

02660 I 0P=8HREPLACED 
02670 92 PRINT 88, I FILE, I OP 

02680 88 FORMAT (*"*, A7, *" HAS BEEN *,A8,* AS DATA FILE.*) 

02690 500 FORMAT (3X,3A10) 
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02700 506 FORMAT (A7) 

02710 510 FORMAT C IX.. 13) 

02720 520 FORMAT (IX# 6511) 

02730 530 FORMAT (1X#7A10) 

02740 540 FORMAT (R2#1X#A3# IX# R2) 

02750 550 FORMAT (7A10) 

02760 560 FORMAT (IX# 21 5) 

02770 590 FORMAT (IX# 221 3) 

02780 600 FORMAT (Al) 

02790 620 FORMAT (22Xt) 

02800 630 FORMAT ( IX# 02# IX# 1 1 # IX# 3A10) 

02810 667 FORMAT(*HEADER FILE "*#A7#*" NOT IN PERMANENT STORAGE.* ) 
02820 668 FORMAT (*ENTER CORRECT AND/OR VALID FILENAME.*) 

02830 STOP 

02840 666 PRINT 667# NAME 
02850 PRINT 668 
02860 GO TO 19 
02870 STOP 
02880 END 

02890 SUBROUTINE ECOLON 

02900 COMMON N# IAND# I OR# I BK# I TAG# I D( 8# 4 ) # LHEAD( 3# 1 60 ) 

02910 DO 10 J= 1 #3 
02920 DO 10 1=1# 10 

02930 LHEAD( J#N) = I SHI FT(LHEAD( J#N ) # 6) 

02940 I WHAT = LHEAD(J#N) .AMD. IAND 

02950 IF ( I WHAT .NE. 063000000000000000000) GO TO 10 

02960 LHEAD(J#N) = LHEAD( J#N) .AND. I OR 

02970 LHEAD(J#N) = LHEAD( J#N) .OR. I BK 

02980 I TAG = 1 

02990 10 CONTINUE 

03000 RETURN 

03010 END 

03020 SUBROUTINE ETERM(NTERM#MSWI T) 

03030C THIS SUBROUTINE ELIMINATES THE TERMINATOR 

03040 IAND = 077000000000000000000 

03050 I OR = .NOT. IAND 

03060 IBK = 055000000000000000000 

03070 IBLNK = 10H 

03080 NNEW = NTERM .AND. IAND 

03090 IF (NNEW .EQ. 047000000000000000000) GO TO 20 

03100 DO 10 K= 1 # 10 

03110 NTERM = I SHI FT( NTERM# 6) 

03120 NNEW = NTERM .AND. IAND 

03130 IF (NNEW .NE. 047000000000000000000) GO TO 10 

03140 NTERM = NTERM .AND. I0R 

03150 MSWIT = 1 

03160 NTERM = NTERM .OR. IBK 

03170 10 CONTINUE 

03180 RETURN 

03190 20 NTERM = IBLNK 

03200 MSWIT = 1 

03210 RETURN 
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03220 END 

03230 SUBROUTINE PRNT ( I AX. KHEAD, MHEAD, MHEAD) 

03240 DIMENSION I FORM C 26), JF0RM( 24)* JHEDC 3> 

03250 DATA IF0RM/5H< 1X» ) , 5H( 2X» ) , 5H( 3X* ) , 5H( 4Xt ) , 5H( 5X» ) , 5H( 6Xt ) , 
03260+ 5H(7Xt ),5H(8Xt ),5H(9X» ), 6H( lOXt ),6H( 1 IX t ), 6H( 12X» ),6H(13Xt ), 
03270+ 6H(14X« I, 6H( 1 5X t ), 6H( 1 6X t ), 6HC 1 7X» ), 6H( 1 BX» > , 6H( 1 9Xt ), 

03280+ 6H(20X» ), 6H(21Xt ), 6H( 22X» ) , 6H( 23X t ) , 6H( 24Xt ) , 6H( 25Xt ) , 6H( 26Xt ) / 
03290 DATA JFORM /5H< A1 » ) , 5H< A2t > , 5HC A3t ) , 5H(A4t ), 5HCA5 » > , 5H( A6t ) , 
03300+ 5H(A7t ),5H(A8t >,5H(A9» >, 6H(A10» ),9H(A10,A1 » > , 9H(A 1 0, A2 » > , 

03310+ 9H(A10, A3t ) , 9H( A10, A4t ) , 9H( A10, A5 t ),9H(A10,A6» ),9H(A10,A7» ) , 
03320+ 9H(A10,A8t ),9H(A10,A9» ),7H(2A10» ) , 1 0H( 2A1 0, A 1 1 ) , 1 0H( 2A1 0, A2 1 ) , 
03330+ 1 0H( 2A1 0. A3 f ) , 10H( 2A10,A4O / 

03340C THIS SUBROUTINE ALLOWS PROGRAM TO PRINT HEADING AND READ 

03350C ANSWER ALL ON THE SAME LINE 

03360 KFIVE = 055000000000000000000 

03370 MASK = 077000000000000000000 

03380 DO 10 1=0,9 

03390 IF (IAX .EQ. 15 GO TO 20 

03400 10 CONTINUE 

03410 STOP 

03420 20 K = 1+1 

03430 NN = I F0RMCK5 

03440 PHI NT NN 

03450 JHED( 1 5 « KHEAD 

03460 JHED(2) = MHEAD 

03470 JHED( 3 5 = NHEAD 

03480 KCOUNT = 0 

03490 KBLNK = 0 

03500 DO 45 M=l,3 

03510 DO 40 1=0,54,6 

03520 KKK = ISHIFT( JHED(M), I ) 

03530 KKK = KKK .AND. MASK 

03540 IF (KKK .NE. KFIVE) GO TO 30 

03550 KBLNK = KBLNK + 1 „ 

03560 IF C KBLNK .EQ. 3) GO TO 50 

03570 GO TO 00035 

03580 30 KBLNK = 0 

03590 35 KCOUNT = KCOUNT + 1 

03600 40 CONTINUE 

03610 45 CONTINUE 

03620 PRINT, *HEADING TOO LONG ABORT* 

03630 RETURN 

03640 50 KCOUNT = KCOUNT - 2 

03650 NN = JFORM < KCOUNT 5 

03660 IF (KCOUNT .GT. 20) GO TO 60 

03670 IF (KCOUNT .GT. 10) GO TO 55 

03680 PRINT NN, KHEAD 

03690 GO TO 00065 

03700 55 PRINT NN, KHEAD, MHEAD 

03710 GO TO 00065 

03720 60 PRINT NN, KHEAD, MHEAD, NHEAD 
03730 65 NFORM = 22- (KCOUNT+K) 
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03740 NN = IFORMCNFORM) 

03750 PRINT NN 
03760 RETURN 
03770 END 

03780 SUBROUTINE DATE 

03790 COMMON N* IAND* I OR, I BK* I TAG, I DC 8* 4 > *LHEADC 3* 1 60 ) 

03800 READ 10* I DATE 
03810 10 FORMAT CAtO) 

03820 15 K1 = ISHIFT< I DATE* - 54 ). AND. 77B 

03830 IF ( (HI .GE. 33B) .AND. CK1 .LE. 44B) ) GO TO 20 

03840 IDY = 33333333333333333333B 

03850 IMON «* C I DATE. AND. 777 77 700000000000000 B) . OR. 000000 55555555555555B 

03860 IYR = I SHI FTC I DATE* -24) .AND. 777 7B 

03870 GO TO 00050 

03880 20 IF CK1 - 368) 30*30*40 

03890 30 K2==I SHI FT( I DATE* -48 ) . AND. 77B 

03900 IF CK2.EQ.55B> GO TO 40 

03910 IDY = I SHI FTC I DATE* -48 ) . OR. 33333333333333330000B 
03920 IMON a C I SHIFT! I DATE* 18) .AND. 77777700000000000000B) • OR. 

039 30+ 000000 5 5 55 5 55 55 555 55 B 

03940 IYR = I SHIFT! I DATE* -6). AND. 7777B 

03950 GO TO 00050 

03960 40 IDY = K1 • OR. 33333333333333333300B 

03970 IMON * C I SHIFT C I DATE* 12) .AND. 77777700000000000000B) . OR. 
03980+00000055555555555555B 


03990 

IYR = I SHI FTC I DATE* 

-12) 

• AND. 7777B 

04000 

50 

I DC 2* 4 ) = IYR. OR. 33333333333333330000B 

04010 

IDC4* 4) = IDY 




04020 

IF 

C IM0N.EQ.3HJAN) 

MON 

a 

1 

04030 

IF 

C IMON.EQ. 3HFEB) 

MON 

s 

2 

04040 

IF 

C IM0N.EQ.3HMAR) 

MON 

8 

3 

04050 

IF 

C IMON. EQ. 3HAPR) 

MON 

8 

4 

04060 

IF 

C IMON.EQ. 3HMAY) 

MON 

= 

'5 

04070 

IF 

C IM0N.EQ.3HJUN) 

MON 

= 

e> 

04080 

IF 

CIM0N.EQ.3HJUL) 

MON 

= 

7 

04090 

IF 

C IMON.EQ. 3HAUG) 

MON 

8 

8 

04100 

IF 

C IMON.EQ. 3HSEP) 

MON 

= 

9 

04110 

IF 

C IMON.EQ. 3H0CT) 

MON 

s 

10' 

04120 

IF 

C IMON.EQ. 3HN0V) 

MON 

= 

11 

04130 

IF 

C IMON.EQ. 3HDEC) 

MON 

8 

12 

04140 

IF 

C IMON.EQ. 3HUNK) 

MON 

S 

13 

04150 

IDC 3* 4) « MON 




04160 

RETURN 




04170 

END 





'---THE E N D 
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00100 PROGRAM RETRVL< INPUT. OUTPUT, TAPE1 3, TAPE1 5) 

00110 DIMENSION I OUTBLC 6) 

00120 DIMENSION IQC 18,7),JC0NSV( 200 ), JWHTSVC 200 ) 

00130 COMMON I QNDEX, I ANDEX, I D( 8, 4) , IDATAN(420), 

00140+ I DATAOC 300 ) , I SHFTL( 10 ) , I SHFTR< 1 0 ) , KALLC 7 ) , I AC 1 8. 7 ) , I QU( 6. 10). 
00150+ INEG( 10), IPRIME( 10). IHNDEXC 10.10). IANOSZC 10). ILHEADC 10). 

00160+ I DATARC 10.2. 10). IDTSIZC 1 0. 1 0 ) . I ELEMC 1 0. 10 ).XDATAR( 2, 10). 

00170+ I CONN ( 10 ) .XSAVEC 1 0 ) , IMAXQ, I FVAA( 120),LCQ( 1 20 ) . I DAT( 6) . 

00 1 80+ IHD( 6, 2, 1 0 ) , INDI VQ( 1 0 ) , I OUTMX. I COMP. I MM AX. IMAXA. I CHAR. I CH. 
00190+ IWD. IWDSIZ, JCHAR. JWD.KNO, I RET. I OUT. ISHFL1 .KA.KB.KC.KD.KE. KF. 
00200+ KG.KH.KI ,KJ, KK. KL. KM. KN . KO. XP, XQ. KR. KS. KT.KU. KV.KW . KX. KY. KZ. 
00210+ KCOLON. KHYPHN.KLP.KRP. KSTAR.KTAB. KDOLLR.KDELTA.KAPOST.KBACKS. 
00220+ KRET. IBLNKS. IBLNK.KDEC. KCOMMA. KCENT. LOWER. ITERM. IQNO.NOQ. 
00230+ IMAXAC. IMAXQC. I STRSW. I START. NOQUES. LI ST. LAST. I GETSW. I SAVE( 20 ) . 
00240+ KEQUAL.NTAPE.KOLON. ICRSUM( 10. 1 0 ) . NUMANSC 1 0 ) . I ANALY. I COPY. 
00250+ I COUNT. I CROSS. I TAB. IANSWC 10). 10. XC 10).X2( 1 0 ) . XCTC 1 0 ) , IBEGA. 
00260+ NO.XMEANC 10).XSD< 10).XMAXC 10),XMINC 1 0 ) . NODECSC 1 0 ) . I D1 (12.6). 
00270+ KZERO.KNINE. IMONTHC 22) . IHEAD( 3. 1 60 ) . 

00280+ IOOC 10).KMASK( 1 0 ) . JMASK( 1 0 ) 

00290 COMMON /MODESW/ RETMODE 
00300 DATA RETMODE / 6H REMOTE / 

00310 DIMENSION ITITLE (8) 

00320 DIMENSION I ARRAY < 2 ) 

00330 DATA I ARRAY/0000004. 0000020 / 

00340 DATA I TI TLE/2HN0, 4HMEAN, 2HSD. 2HSE. 3HMAX. 3HMIN. 1 OHMEAN + 2SD, 
00350+ 1 OHMEAN - 2SD/ 

00360 DATA I 0UTBL/4HLI ST. 4H COPY. 5H COUNT. 6HTAB-SD. 8H TABULATE. 

00370+ 8HCR0SSTAB/ 

00380 CALL CLOCK(IX) 

00390 CALL DATERCIS) 

00400 PRINT 33. IS. IX 

00410 33 FORMAT < * PROG RAM 3 RETRI EVE*. 4X. *DATE: *, A9. 4X. *TIME s * . A9. ///) 
00420 100 CALL DR0P1 (13) 

00430 REWIND 13 

00440 PRINT. *ENTER NAME OF DATA FILE:*, 

00450 19 READ, NAME 
00460 18 FORMAT (A7) 

00470 KTIME = 1 

00480 CALL PFUR( 3HRET, 1 3, NAME, 0, I STA ) 

00490 IF (I STA «ES« 5) GO TO 61 

00500 IF (RETMODE .EQ. 5HBATCH) GO TO 9951 

00510 IF (RETMODE .EQ. 6HPSEUD0) GO TO 9949 

00520 9949 DO 9950 1=1,8 

00530 DO 9950 J=l,7 

00540 9950 IQ(I.J) = 10H 

00550 IQ(3, 1 )=10H( ALL OR SP 

00560 I Q( 4, 1 ) = 10HECI FY ONE 

00570 IQ(5,1)=1 OHTO SIX) 

00580 IQ(3,2) = IQ(3,3) = IQ( 3, 5 ) = I Q( 3, 7 ) = 1 0 ( 3, 1 ) 

00590 IQ(4,2)=IQ(4,3)= 10HECI FY ONE) 

00600 I Q( 3, 4 )= 10H( ALL, ONE, 

00610 IQ(4,4)=1 OH OH RANGE 
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00620 IQC 5*4) = 10H0F DATES) 

00630 IQ(4*5)=IQ(4*7)= 10HECI FY) 

00640 IQC3*6)=10HCLIST*C0PY 

00650 IQC 4# 6) = 1 OH* COUNT* ANA 

00660 I QC 5* 6) = 1 OHLYZE* TABUL 

00670 IQC 6* 6)=10HAT£*CR0SS- 

00680 IQC7*6)=10HTAB) 

00690 IQC 1*5) = iOHCOMDITIONS 

00700 IQC 1*6) = 10HACTI0N 

D0710 IQC 1 >7) = 10HWHAT 

00720 GO TO 9952 

00730 9951 READ 105# C( IQCI* J)* 1=1*8)* J=l*7) 

00740 105 FORMAT C7A10* A2) 

00750 9952 CONTINUE 

00760 NTAPE =13 

00770 KLUNK = 0 

00780 LIST = IOUTBLC 1 ) 

00790 I COPY = IOUTBL <2) 

00800 I COUNT = IOUTBL (3) 

00810 I ANAL Y = IOUTBL C4> 

00820 ITAB = IOUTBL <5) 

00830 I CROSS = IOUTBL C 6) 

00840 CALL INIT 

00850 115 REWIND NTAPE 

00860 CALL REDREC 

00870 DO 120 K= 1# 4 

00880 DO 120 J=l»2 

00890 120 IQCJ,K) = IHEADC J*K) 

00900 GO TO 129 

00910 125 IF C C 1 0. EQ. 2) . OR. C I O.EQ. 4) . OR. C 1 0. EQ. 5 ) ) GO TO 112 
00920 GO TO 129 

00930 112 PRINT* *DID YOU COPY OR TAB ANY INFO YOU WANT TO SAVE:** 
00940 READ 980* KEEP 
00950 980 FORMAT CA1) 

00960 IF CKEEP.EQ. 1HY) GO TO 380 
00970 129 REWIND 15 
00980 REWIND NTAPE 

00990 IF CNTAPE - 14) 127# 126* 127 

01000 126 NTAPE =13 

01010 REWIND NTAPE 

01020 127 CONTINUE 

01030 IF C KLUNK .EQ. 0) GO TO 128 

01040 IF CKTIME .EQ. 0) GO TO 128 
01050 CALL SECONDC TTTT) 

01060 TPRINT = TTTT - TTO 

01070 PRINT 9912* TPRINT 

01080 9912 FORMAT C5H******* THIS RETRIEVAL T00K*F6.3#* SECONDS*) 

01090 128 CONTINUE 

01100 IC0MP=0 

OHIO I AB0RT=0 

01120 DO 140 1=1*10 

01130 XMAXCI) = -9999999 
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01140 XMIN(I) = 9999999 

01150 IANSW(I) = 0 

01160 IANOSZf I >=0 

01170 INEG( I )= 1 

01180 X(I) = 0 

01190 X2( I ) = 0 

01200 XCTCI) = 0 

01210 NODECS(I) = 0 

01220 DO 140 J=l,10 

01230 ICRSUMC I j J) = 0 

01240 I DTSIZ ( I , J) =0 

01250 IELEM( I , J) =0 

01260 DO 135 K= 1 , IMAXQ 

01270 I QU(K, J)=I BLNKS 

01280 DO 135 L=l,2 

01290 XDATAR(L,<J) = 0 

01300 I DATARC I»L»J) = I BLNKS 

01310 135 IHD( K, L, J) =1 BLNKS 

01320 140 I CONN C I )=0 

01330 DO 145 1 = 1,1 MAXA 

01340 DO 145 J= 1,6 

01350 145 IDKI.J) = IBLNKS 

01360 IC0MP=0 

01370 I LAST=0 

01380 DO 150 1=1,20 

01390 150 ISAVEC I )=IBLNKS 

01400 IF (KLUNK .EG. 1) GO TO 9900 

01410 CALL SECOND(TTO) 

01420 9900 CALL SECONDC TTTT) 

01430 9911 FORMAT (5H*****,* CP TIME IS*F6.3,4H ***) 

01440 TTO = TTTT 

01450 151 KLUNK = 1 

01460 DO 265 1=1,7 

01470 152 KNO=I 

01480 IF ( IQ( 1, I )- I BLNKS) 155,260,155 

01490 KODE = 0 

01500 155 IF (KODE .NE. 1) PRINT,/,/ 

01510 KODE = l 

01520 PRINT 1 60, (IQ(«J, I),J=1,2) 

01530 160 FORMAT (A10,A9O 

01540 CALL TYPEN 

01550 GO TO (370,165,245,166,125,100), IRET 

01560 166 GO TO (265,265,265,265,201,265,211), I 
01570 165 GO TO (265,265,265,170,203,230,213), I 
01580 170 CALL DATEIN 

01590 GO TO (175,175,175,265), IRET 

01600 175 PRINT 180 

01610 180 FORMAT ( 1 6H BAD DATE ) 

01620 GO TO 255 

01630 201 DO 202 J= 1,200 

01640 202 IDATAN(J) = JCONSV(J) 

01650 GO TO 205 
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01660 203, DO 204 J= 1 , 200 
01670 204 JCONSV(J) = I DATAN( J) 

01680 205 IF (KALL(5).EQ. 1) GO TO 265 

01690 KN0=1 

01700 NOQ = 10 

01710 ICOMP = 10 

01720 210 CALL WHAT 

01730 I BEGA= I COMP+ 1 

01740 GO TO (220,265). IRET 

01750 211 DO 212 J=l,200 

01760 212 IDATAN(J) = JWHTSV(J) 

01770 GO TO 215 

01780 213 DO 214 J=l,200 

01790 214 JWHTSV(J) = IDATAN(J) 

01800 215 IF ( KALL ( 7 ) • EQ • 1 ) GO TO 265 
01810 KN0=IC0MP+1 

01820 N0Q=10 

01830 GO TO 210 

01840 220 PRINT 222 

01841 222 FORMAT! 4H****,* DELIMI TORS ENTERED INCORRECTLY.*) 

01850 GO TO 255 

01860 230 I0UT=IA( 2, 6) 

01870 DO 235 K=l,6 

01880 10 = K 

01890 IF ( I OUT- 1 OUTBL(K) ) 235,265,235 

01900 235 . CONTINUE 

01910 PRINT 221 

01911 221 F0RMAT(4H****,* ACTION TYPE INCORRECT. MUST BE: LIST,* 

01912+ * COPY, COUNT, TAB-SD,*,/,* TABULATE, OR CROSSTAB.*,/) 
01920 GO TO 255 

01930 245 PRINT 250, I 

01940 250 FORMAT! 4H****, * NO TERMINATING CHARACTER IN QUESTION* 
01941+ *, 16,*. RE-ENTER.*) 

01950 255 GO TO 152 

01960 260 KALL ( KN 0 ) = 1 

01970 265 CONTINUE 

01980 IF ( I ABORT) 125,270,125 

01990 270 I FREC-0 

02000 IFIND=0 

02010 IF CIO - 4) 290,275,275 

02020 275 CONTINUE 

02030 I START = ICOMP + 1 

02040 PRINT 285, ( I QU( 1 , J) , J=I START, LAST) 

02050 WRITE (15,285) ( I QU( 1 , J) , J=I START, LAST ) 

02060 285 FORMAT ( /21X,5( 1X,A10) ) 

02070 IF ( ICROSS - IOUT) 290,286,290 

02080 286 PRINT 287, ( ( IDATAR(K, 1 , J) ,K= 1 , 8 ), J=I START, LAST) 

02090 287 FORMAT ( 17X, 5( 3X, 8R1 ) ) 

02100 PRINT 288, ( (XDATAR( I , J) , I = 1 , 2) , J= I START, LAST ) 

02110 288 FORMAT ( 17X, 5( F5. 1 , 1H-, F5. 1 ) ) 

02120 290 CALL REDREC 

02130 GO TO (320, 295, 930, 424, 920), IRET 
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02140 295 CALL CKID 
02150 GO TO <290, 300, 320). I RET 

02160 300 I FREC= 1 + 1 FREC 

02170 CALL BOOL 

02180 305 GO TO < 290, 306, 900, 9 1 0, 920, 424, 600 ), I RET 

02190 306 I FIND = I FIND + 1 

02200 IF < I OUT. EQ. I OUTBLC 2) ) CALL WRITREC 

02210 GO TO 290 

02220 320 IF CIFREC) 360,360,325 

02230 325 IF CIFIND) 350,350,327 

02240 327 IF CIOUT - IANALY) 328,500,328 

02250 328 IF <IOUT - ICROSS) 330,450,330 

02260 330 PRINT 335, I FIND 

02270 335 FORMAT C9HC0UNT IS ,16) 

02280 337 GO TO 125 

02290 IF < IDATANC 1 ) • EQ. 8HRESTART* ) GO TO 250 

02300 350 PRINT 355 

02310 355 FORMAT <//* NONE OF THE SPECIFIED RECORDS CONTAIN THE INFO*) 
02320 GO TO 125 

02330 360 PRINT 365 

02340 365 FORMAT < //32H SPECIFIED RECORD IS NOT IN FILE) 

02350 GO TO 125 

02360 370 PRINT 375 

02370 375 FORMAT < 1 5H END OF PROGRAM) 

02380 GO TO 435 

02390 380 PRINT,* WHAT NAME DO YOU WANT TO CALL IT:*, 

02400 383 READ 18,JSAVE 

02410 CALL PFURC 3HSAV, 1 5, JSAVE,0, I STA) 

02420 IF (I STA .EQ. 4) GO TO 381 

02430 PRINT 382,JSAVE 

02440 GO TO 370 

02450 381 PRINT 386,JSAVE 

02460 PRINT, *RE-ENTER ANOTHER NAME:*, 

02465 GO TO 383 

02480 382 F0RMATCA7,* HAS BEEN SAVED.*) 

02490 386 FORMATC A7 , * ALREADY A PERMANENT FILE.*) 

02500 435 STOP 

02510 450 I FIND = 0 

02520 DO 460 INDEX = 1,1 COMP 

02530 IBEGA = I COMP + 1 

02540 IF < IDTSIZC 1, INDEX) - 1000) 456,451,451 

02550 451 CONTINUE 

02560 PRINT 455, I QUC 1 , INDEX) , <XDATAR< I , INDEX ) , I = 1 , 2 ) , 

02570+ <ICRSUM< INDEX, J) , U=I BEGA, LAST) 

02580 455 FORMAT CA4,F5. 1, 1H-,F5. 1,5< 4X, 17)) 

02590 DO 453 J= I BEGA, LAST 

02600 453 I FIND = I FIND + I.CRSUMC INDEX, J) 

02610 GO TO 460 

02620 456 JWD = 1 

02630 JCHAR = 0 

02640 ~ IDATA0C1) = IBLNKS 

02650 ISTRSW = 3 
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02660 DO 457 1=1.10 

02670 I CHAR = I DATARCI . 1 . INDEX) .AMD. 77B 

02680 CALL STRCH 

02690 457 COMTINUE 

02700 458 FORMAT ( IX. A4. IX. A10. IX. 5C 4X. 1 7 ) ) 

02710 PRINT 458. C I QUC 1 . INDEX) . I DATAOC 1 ) . 

027 20+ C I CRSUMC I NDEX. J) . J= I BEGA. LAST ) ) 

02730 DO 459 J=1 BEGA. LAST 

02740 459 I FIND = I FIND + ICRSUMC INDEX. J) 

02750 460 CONTINUE 

02760 IDATAOC 1 5 = IBLNKS 

02770 GO TO 330 

02780 500 IOUT=LIST 

02790 CALL FORMA 

02800 CALL FORMA 

02810 DO 550 I =1.8 

02820 IDATAOC 1) = ITITLECI) 

02830 JWD = 2 

02840 JCHAR =6 

02850 DO 540 J= I BEGA. LAST 

02860 KNO = J 

02870 IF C XCTC KNO ) -2) 502.502.501 

02880 501 IANSWCKNO) = 1 

02890 GO TO 505 

02900 502 IANSWCKNO) = 0 

02910 IF CXCTCKNO)) 529.529.505 

02920 505 IF C IANOSZCKNO) ) 520.520.510 

02930 510 IF C IDTSIZC l.KNO) - 1000) 530.520.520 

02940 520 GO TO C 521 . 522. 523. 524. 525. 526. 527. 528 ) . I 

02950 521 CONTINUE 

02960 XSAVECKNO) = XCTC KNO) 

02970 GO TO 529 

02980 522 CONTINUE 

02990 XMEANCKNO) = XCKNO) /XCTC KNO) 

03000 XSAVECKNO) = XMEANCKNO) 

03010 GO TO 529 

03020 523 CONTINUE 

03030 XSDCKNO) = SQRTCX2CKN0) /XCTC KNO) -XMEAN C KNO) *XMEANC KNO) ) 
03040 XSAVECKNO) = XSDCKNO) 

03050 GO TO 529 

03060 524 CONTINUE 

03070 XSAVECKNO) = XSDC KNO) /C SORTC XCTC KNO) ) ) 

03080 GO TO 529 

03090 525 XSAVECKNO) = XMAXCKNO) 

03100 GO TO 529 

03110 526 XSAVECKNO) = XMINCKNO) 

03120 GO TO 529 

03130 527 XSAVECKNO) = XMEANCKNO) + 2 * XSDCKNO) 

03140 GO TO 529 

03150 528 XSAVECKNO) = XMEANCKNO) - 2 * XSDCKNO) 

03160 529 CALL PFLFIX 

03170 GO TO 540 
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03180 530 ICHAR = IBLNK 

03190 DO 535 M = M3 

03200 535 CALL STRCH 

03210 540 CONTINUE 

03220 550 CALL FORMA 

03230 GO TO 125 

03240 600 PRINT 601 

03250 601 F0RMATC4H****,* FATAL ERROR - ATTEMPTED TO WRITE ON NEW* 
03251+ * COPY FILE.*) 

03260 GO TO 435 

03270 900 PRINT 901 

03280 901 F0RMATC4H****,* FATAL ERROR - EOF ON WRITE.*) 

03290 GO TO 435 

03300 910 PRINT 911 

03310 911 FORMATC 4H****, * FATAL ERROR - DEVICE ERROR.*) 

03320 GO TO 435 

03330 920 PRINT 921 

03340 921 FORMATC 4H****, * FATAL ERROR - END OF TAPE ON WRITE.*) 

03350 GO TO 435 

03360 930 PRINT 931 

03370 931 FORMAT ( 4H****, * FATAL ERROR - EOF ON READ.*) 

03380 GO TO 435 

03390 424 PRINT 426 

03400 426 FORMAT C 4H****, * FATAL ERROR - ICK ERROR.*) 

03410 GO TO 435 

03420 61 PRINT,* * 

03430 PRINT 62, NAME 

03440 PRINT, *RE-ENTER CORRECT DATA FILE NAME:*, 

03450 GO TO 19 

03460 62 FORMAT C A7 , * NOT IN PERMANENT STORAGE.*) 

03470 END 

03480 SUBROUTINE REDREC 

03490 COMMON I QNDEX, I ANDEX, I DC 8, 4 ) , IDAtANC420), 

03500+ I DATAOC 300 ) , I SHFTLC 1 0 ) , I SHFTRC 10), KALLC 7 ) , I A< 1 6, 7 ) , I QU< 6, 10), 
03510+ INEGC 10),IPRIMEC 10), IHNDEXC 10, 10), IANOSZC 10), ILHEADC 10), 

03520+ IDATARC 10,2, 10), IDTSIZC 10, 10), IELEMC 10, 10),XDATAR( 2, 10), 

03530+ I CONN ( 10),XSAVEC 10) , IMAXQ, IFWAAC 1 20 ),LCQC 1 20 ) , I DAT( 6) , 

03540+ IHDC 6, 2, 1 0 ) , INDI VQ( 10), I OUTMX, I COMP, I NMAX, IMAXA, I CHAR, I CH, 
03550+ I WD, IWDSIZ , JCHAR, JWD, KN 0, I RET, I OUT, I SHFL 1 , KA, KB, KC, KD, KE,JCF, 
03560+ KG, KH, KI , K J, KK, KL, KM, KN,K0, KP, KQ, KR, KS, KT, KU, KV, KW, KX, KY, KZ , 
03570+ KCOLON, KHYPHN, KLP, KRP, KSTAR, KTAB, KDOLLR, KDELTA, KAPOST, KBACKS, 
03580+ KRET, IBLNKS, IBLNK, KDEC, KCOMMA, KCENT, LOWER, ITERM, IQNO,NOQ, 
03590+ IMAXAC, IMAXQC, I STRSW, I START, NOQUES, LI ST, LAST, I GETSW, I SAVEC 20 ) , 
03600+ KEQUAL,NTAPE, KOLON, ICRSUMC 10,10 ) ,NUMANSC 10), I ANALY, I COPY, 
03610+ I COUNT, I CROSS, I TAB, IANSWC 10), IO,XC 10),X2C 10),XCTC 10), IBEGA, 
03620+ NO,XMEANC 10),XSDC 10),XMAXC 1 0 ) ,XMI NC 1 0 ) ,NODECSC 10) , ID1 { 1 2, 6) , 
03630+ KZERO,KNINE, IMONTHC 22), IHEADC 3, 1 60 ) , 

03640+ IOOC 10) ,KMASK( 10), JMASKC 10) 

03650 DIMENSION IARRAYC 2) 

03660 DATA IARRAY/0000004, 0000020/ 

03670 1 DO 105 I=1,I0UTMX 

03680 105 I DATAOC I )= IBLNKS 


39 



** "RETREVE" — RETRIEVAL PROGRAMS FOR MIMS SYSTEM 
08/05/71. 12.34.08. 


03690 ISTAT = 0 

03700 IC = 0 

03710 DO 106 1=1,4 

03720 106 I DC8, I ) = IBLNKS 

03730 READ CNTAPE, 180) I QNDEX, I ANDEX 

03740 IF CEOF,NTAPE) 140,107 

03750 107 DO 108 1=1,4 

03760 108 READ CNTAPE,170) C I DC J, I ), J= 1 , 7 ) 

03770 DO 110 1=1,1 QNDEX 

03780 110 READ CNTAPE, 170) C IHEADC J, I ) , J= 1 , 3) 

03790 IF C I QNDEX .LE. 65) GO TO 1 1 2 
03800 READ CNTAPE,160) (LOGIC I), 1 = 1, 65) 

03810 READ CNTAPE, 160) (LOGIC I ), I = 66, I QNDEX ) 

03820 GO TO 114 

03830 112 READ CNTAPE,160) C LCQC I ) , I = 1 , I QNDEX) 

03840 114 MPT = 22 

03850 MZT = 1 

03860 115 MWT = MZT + 21 

03870 IF C I QNDEX-MPT ) 117,117,116 

03880 116 READ CNTAPE, 190) C I FWAAC I ) , I =MZT,MWT) 

03890 MPT = MPT + 22 

03900 MZT = MWT + 1 

03910 GO TO 115 

03920 117 READ CNTAPE, 190) C I FWAAC I ) , I =MZT, I QNDEX) 
03930 J = 1 

03940 IZAN = CIANDEX/6) + 1 
03950 IPAN = CIZAN-1)*6 

03960 IF CIPAN .EQ. IANDEX) IZAN=IZAN-1 
03970 DO 120 M=1,IZAN 
03980 K = J+5 

03990 READ CNTAPE, 170) ( I DATANC I ) , I = J,K) 

04000 120 J= J+6 

04010 I DC 3, 4) = I DC 3, 4 ) .AND. 77B 

04020 125 I RET = 2 

04030 IF C I QNDEX- 1) 130,130,135 

04040 130 I RET = 1 

04050 RETURN 

04060 135 I = IQNDEX+1 

04070 I FWAAC I ) = IANDEX+1 

04080 LCQCI) = 1 

04090 NOQUES = I QNDEX 

04100 JWD = 0 

04110 RETURN 

04120 140 I QNDEX = 1 

04130 IANDEX = 1 

04140 GO TO 130 

04150 160 FORMAT C IX, 6511) 

04160 170 FORMAT C1X,7A10) 

04170 180 FORMAT C1X,2I5) 

04180 190 FORMAT C IX, 2213) 

04190 END 

04200 SUBROUTINE BOOL 


40 



** "RETREVE"' — RETRIEVAL PROGRAMS FOR MIMS SYSTEM 
08/05/71. 12.34.08. 


04210 DIMENSION IARRAYC 2) 

04220 DIMENSION ITRUE<10> 

04230 COMMON I QNDEX, I ANDEX, I DC 8, 4 ) , IDATANC420), 

04240+ IDATAOC 300 ), I SHFTLC 1 0 ) , I SHFTRC 1 0 ) .KALLC 7 ) , I AC 1 8, 7 ) , I QUC 6, 1 0 ) , 
04250+ INEGC 10), IPRIMEC 10). IHNDEXC 10. 10). IANOSZC 10). ILHEADC 10). 

04260+ IDATARC 10.2. 10),IDTSIZC 10. 10). IELEMC 10, 10).XDATARC 2.10). 

04270+ I CONN C 10),XSAVEC 10), I MAXES, IFWAAC 120),LCQC 120), IDATC6), 

04280+ IHDC 6, 2, 10 ), INDI VQC 1 0 ) , I OUTMX, I COMP, INMAX, IMAXA, I CHAR, I CH, 
04290+ IWD, IWDSIZ, JCHAR, JWD.KNO, IRET, IOUT, I SHFL 1 , KA, KB.KC, KD, KE.KF, 
04300+ KG , KH, KI , KU, KK, KL, KM, KN, KO, KP, KQ, KR, KS, KT, KU, KV, KV, KX, KY, KZ , 
04310+ KCOLON.KHYPHN.KLP, KRP, KSTAR.KTAB, KDOLLR, KDELTA.KAPOST.KBACKS, 
04320+ KRET, I BLNKS, I BLNK, KDEC, KCOMMA, KCENT, LOWER, I TERM, I ON 0, NOO, 
04330+ IMAXAC, IMAXQC, I STRSW, I START.NOQUES.LI ST, LAST, I GETSW, I SAVEC 20 ) , 
04340+ KEQUAL.NTAPE.KOLON, ICRSUMC 10, 1 0 ) , NUMANSC 1 0 ) , I ANALY, I COPY, 
04350+ ICOUNT, ICROSS, ITAB, IANSWC 10), IO.XC 10),X2C 10),XCTC 10), IBEGA, 
04360+ NO.XMEANC 10),XSDC 10),XMAXC 10),XMINC 10),M0DECSC 10), I D1 Cl 2, 6), 
04370+ KZERO.KNINE, IM0NTHC22), I HEADC 3, 1 60 ) , 

04380+ IOOC 10),KMASKC 10), JMASKC 10) 

04390 DATA I ARRAY/0000004, 0000020/ 

04400 I ROW = 0 

04410 I COL = 0 

04420 L0WER=0 

04430 IF CKALLC5)) 145,145,105 

04440 105 IF C I OUT- 1 COUNT ) 110,310,110 
04450 110 IF CKALLC7)) 220,220,115 
04460 115 IF C I OUT- 1 ANALY) 120,310,120 
04470 120 IF C I OUT- 1 COPY) 135, 125,135 
04480 125 IQNDEX=NOQUES 

04490 IF CNTAPE - 15) 126, 400, 400 

04500 400 IRET = 7 

04510 RETURN 

04520 126 IC = 0 

04530 1107 I DETEC = I ARRAY C 2 ) .AND. I STAT 

04540 IF C I DETEC) 920, 310, 920 ’ 

04550 135 CALL HEAD IN 

04560 DO 140 I=5,N0QUES 

04570 I QNDEX= I 

04580 CALL FORMT 

04590 140 CONTINUE 

04600 GO TO 305 

04610 145 DO 180 K=1,IC0MP 

04620 KNO = K 

04630 I START = 1 

04640 150 CALL FINDQ 

04650 GO TO C 175, 155), IRET 

04660 155 IF C IANOSZC KNO) ) 170,170,160 

04670 160 CALL MACHDT 

04680 I = I RET* INEGC KNO) 

04690 IF Cl) 165,165,170 
04700 165 I START = IQNDEX + 1 
04710 GO TO 150 
04720 170 INDI VQC KNO ) = 1 
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04730 

GO TO 

180 

04740 

175 INDIVGKKNO) = -1 

04750 

180 CONTINUE 

04760 


DO 210 1=1. I COMP 

04770 


IGROUP=I COMP- I + 1 

04780 


I SUM=ICONN( I GROUP) 

04790 


DO 195 IQN0=1. I COMP 

04800 


J=IELEM( IQNO. I GROUP) 

04810 


IF <J-i) 195.190.185 

04820 

185 

J=ITRUE< J) 

04830 


GO TO 195 

04840 

190 

«J=INDIVQ< IQNO) 

04850 

195 

I SUM=I SUM+ J 

04860 


IF < I SUM) 200.205.205 

04870 

200 

ITRUE< I GROUP) =- 1 

04880 


GO TO 210 

04890 

205 

ITRUE< I GROUP) =1 

04900 

210 

CONTINUE 

04910 


IF < I TRUEC 1 ) > 215.105.105 

04920 

215 

IR£T= 1 

04930 


RETURN 

04940 

220 

CONTINUE 

04950 


DO 240 1=1 BEG A. LAST 

04960 


KNO=I 

04970 


INDIVQ <KNO) = 0 

04980 


IANSWCKNO) = 0 

04990 


NUMANSCKNO) = 0 

05000 


I START= 1 

05010 


CALL FINDQ 

05020 


GO TO <240.230). I RET 

05030 

230 

IF ( I OUT - LIST) 235.240.235 

05040 

235 

CALL MACHDT 

05050 


IF CIRET) 240.239.239 

05060 

239 

INDIVQ <KNO) =1 

05070 

240 

CONTINUE 

05080 

241 

CONTINUE 

05090 

246 

IF < I OUT - I CROSS) 244.325.244 

05100 

244 

IF <10 - 4) 255.245.245 

05110 

245 

CONTINUE 

05120 


I STRSW= 1 

05130 


JWD= 1 

05140 


JCHAR=0 

05150 


IQNDEX=4 

05160 


KN0=4 

05170 


IA< 1.4)=IBLNKS 

05180 


I A< 2. 4) = 1 BLNKS 

05190 


CALL FORMT 

05200 


K=I COMP+ 1 

05210 


ISTRSW = 3 

05220 


JVD = 1 

05230 


JCHAR = 0 

05240 


DO 1290 M = K. LAST 
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05250 

05260 

05270 

05280 

05290 

05300 

05310 

05320 

05330 

05340 

05350 

05360 

05370 

05380 

05390 

05400 

05410 

05420 

05430 

05440 

05450 

05460 

05470 

05480 

05490 

05500 

05510 

05520 

05530 

05540 

05550 

05560 

05570 

05580 

05590 

05600 

05610 

05620 

05630 

05640 

05650 

05660 

05670 

05680 

05690 

05700 

05710 

05720 

05730 

05740 

05750 

05760 


KNO = M 

IF ( IDTSIZ C 1 .KNO ) - 1000) 1250.1270.1250 
1250 J = NUMANSCKNO) 

DO 242 JH = 1 .NOQUES 

IF C I QUC 1 .KNO) . EQ. I HEAD ( 1 . JH ) ) GO TO 243 

242 CONTINUE 
GO TO 1270 

243 JDAT = IFWAACJH) 

KPROS = ISHIFTC IDATANC JDAT). -54) .AND.77B 
IF (KPROS. EQ. 63B) GO TO 247 
GO TO 1270 

247 IDATANCJDAT) = I DATAN( JDAT) . AND. 7777777777777777B 
DO 1255 I = 1.4 
I CHAR = IBLNK 
1255 CALL STRCH 
I = 8 

DO 249 K - 1.7 
I = .1 - 1 

249 IDATAR (I.J.KNO) = I SHI FTC I DATANC JDAT) . - ( 6*K) ) . AND. 77B 
DO 1268 I « 1.7 
I CHAR = I DA TAR( I.J.KNO) 

1268 CALL STRCH 
GO TO 1290 
1270 CALL PFLFIX 
1290 CONTINUE 

PRINT 250. IDC2. 1).IA< 1.4). Cl DATA Of I). 1 = 1. 6) 

WRITE C15.250) I DC 2. 1 ) . I AC 1 , 4) . C I DATAOC I ) , 1 = 1 . 6) 

250 FORMAT C A8. A8. 5A1 0. A5 ) 

DO 252 I = 1.28 
252 IDATAOCI) = IBLNKS 
GO TO 310 

255 IF C I OUT- 1 COPY) 260.125.260 
260 CALL HEADIN 

DO 300 K=IBEGA.LAST 
KNO=K 

265 J=IPRIMECKNO) 

IF CJ) 300.300.270 
270 DO 295 I=1.J 

IQNDEX=IHNDEX( I.KNO) 

IF CIQNDEX) 275.295.275 
275 IF C IQNDEX-ILHEADC I ) ) 280.295.280 

280 IF CJ-I) 290.285.290 

285 L0WER=1 
290 ILHEADC I )=IQNDEX 
CALL FORMT 

IF Cl SAME .EQ. 1) GO TO 305 
L0WER=0 

295 CONTINUE 

296 I START=I QNDEX+ 1 
CALL FINDQ 

GO TO C 300. 265 ) . IRET 
300 CONTINUE 
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05770 305 CALL FORMA 

05780 308 PRINT 315 

05790 315 FORMAT ( 1 OH********** ) 

05800 310 I RET=2 

05810 RETURN 

05820 325 DO 350 I = 1,1 COMP 

05830 IF (INDIVQCD) 350,350,330 

05840 330 DO 340 J = IBEGA,LAST 

05850 IF (INDIVGKJ)) 340,340,335 

05860 335 ICRSUMCI,J) = ICRSUMCI,J) + 1 

05870 340 CONTINUE 

05880 350 CONTINUE 

05890 GO TO 310 

05900 900 IRET = 3 

05910 RETURN 

05920 920 IRET = 5 

05930 RETURN 

05940 END 

05950 SUBROUTINE CKID 

05960 COMMON I QNDEX, I ANDEX, I D< 8, 4) , IDATAN(420), 

05970+ I DAT AO ( 300 ) , I SHFTLC 1 0 ) , I SHFTRt 10), KALL C 7 ) , I At 1 8, 7 ) , I OUt 6, 1 0 ) , 
05980+ INEGt 10 ) , IPRIMEt 10), IHNDEXC 10, 10), IANOSZf 10), ILHEADC 10), 

05990+ I DATARt 10,2, 10),IDTSIZ( 10, 10 ) , I ELEMC 1 0, 10), XDATARt 2, 10), 

06000+ I CONN < 10) »XSAVE( 10) , IMAXQ, I FWAAt 120) >LCQC 1 20 ) , I D'ATC 6) , 

060 1 0+ IHDC 6, 2, 10 ), INDI VGK 10 ) , I OUTMX, I COMP, INMAX, IMAXA, I CHAR, I CH, 
06020+ IWD, IVDSIZ, JCHAR, JWD,KN0, I RET, I OUT, ISHFL1 ,KA,KB,KC,KD,KE,KF, 
06030+ KG,KH,KI,KJ,KK,KL,KM,KN,KO,KP,KQ,KR,KS,KT,KU,KV,KW,KX,KY,KZ, 
060 40+ KCOLON, KHYPHN , KLP, KRP, KSTAR, KTAB, KDOLLR, KDELTA, KAPOST , KBACKS, 
06050+ KRET, IBLNKS, I BLNK,KDEC,KCOMMA, KCENT,L0UER, I TERM, I QNO,NOG), 
06060+ IMAXAC, IMAXQC, I STRSW, I START, NOQUES, LI ST, LAST, IGETSW, I SAVE( 20 ) , 
06070+ KEQUAL,NTAPE,KOLON, ICRSUMt 10, 1 0 ) , NUMANSC 1 0) , I ANALY, I COPY, 
06080+ ICQUNT, ICROSS, ITAB, lANSWt 10),I0,XC 10),X2< 10),XCTC 10),IBEGA, 
06090+ NO,XMEAN< 10),XSD< 10),XMAXC 10 ) ,XMIN< 1 0 ) , NODECSt 10), ID1 ( 12, 6), 
06100+ KZER0,KNINE, IMONTHC 22) , IHEADC 3, 1 60 ) , 

06110+ I00< 10),KMASK( 10), JMASKC 10) 

06120 DIMENSION KLASTC8) 

06130 DATA I F0RM/6HF0RMAT/ 

06140 1=1 

06150 IF < KALL < I ) ) 15,15,10 

06160 10 IF < IDC 2, 1 ) - IFORM) 100,145,100 

06170 15 L=1 

06180 KTRK = 0 

06190 DO 20 J= 2, IMAXA 

06200 KCT=1 

06210 L=L+1 

06220 KLASTIL) = ID(J, I) 

06230 DO 50 KLK = 0,54,6 

06240 LOOK = I SHIFT< I At J, I ) ,KLK) . AND. 77000000000000000000B 

06250 IF (LOOK.EQ. 55000000000000000000B) KTRK = KTRK + 1 

06260 IF (KTRK - 2) 60,70,70 

06270 60 KCT = KCT + 1 

06280 50 CONTINUE 
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06290 

20 

CONTINUE 

06300 

70 

LMN = KCT-1 

06310 

KLAST(L) = ID(J, I) 

06320 


DO 90 J = 2,L 

06330 


IF ( I A< J, I ) - KLAST(J)) 145,90,145 

06340 

90 

CONTINUE 

06350 

100 

1 = 1 + 1 

06360 


IF <1 - 3) 105, 105, 115 

06370 

105 

II = I 

06380 


IF (KALL(I)) 15,15,100 

06390 

115 

CONTINUE 

06400 


IF <KALL< 4) ) 120,120,140 

06410 

120 

DO 125 1=1,3 

06420 


J=I + 1 

06430 


IF CID< J,4)-IDAT< I ) ) 145,125,130 

06440 

125 

CONTINUE 

06450 


GO TO 140 

06460 

130 

DO 135 1=2,4 

06470 


J=I + 2 

06480 


IF (ID(I,4)-I DAT ( J) ) 140,135,150 

06490 

135 

CONTINUE 

06500 

140 

I RET=2 

06510 


GO TO 170 

06520 

145 

I RET= 1 

06530 


GO TO 170 

06540 

150 

IF (II-l) 155,165,155 

06550 

155 

N= I I - 1 

06560 


DO 160 J=1,N 

06570 


IF (KALLC J)) 160,160,145 

06580 

160 

CONTINUE 

06590 

1 65 

I RET=3 

06600 

170 

RETURN 

06610 


END 

06620 


SUBROUTINE DATE IN 

06630 

COMMON I QNDEX, I ANDEX, I DC 8, 4 ) , I DATANC 420 ) 


06640+ I DATAOC 300 ) , I SHFTLC 10), ISHFTRC 1 0 ) , KALLC 7 ) , I AC 1 8, 7 ) , I Q.UC 6, 1 0 ) , 
06650+ INEGC 10 ), IPRIMEC 10) , IHNDEXC 10,10), IANOSZC 10 ), I LHEAD( 10) , 
06660+ IDATAR< 10,2,10), IDTSIZC 10, 10), IELEMC 10, 1 0 ) , XDATARC 2, 10), 
06670+ I CONN ( 10),XSAVE< 10), IMAXQ, IFWAAC 1 20),LCQC 120), IDATC 6), 

06680+ IHDC 6, 2, 10 ) , INDI VOC 1 0 ) , I OUTMX, I COMP, INMAX, IKAXA, I CHAR, I CH, 
06690+ IWD, IWDSIZ, JCHAR, JWD,KNO, I RET, I OUT, I SHFL1 ,KA,KB,KC,KD,KE,KF, 
06700+ KG,KH,KI,K«J,KK,KL,KM,KN,KO,KP,KQ,KR, KS, KT, KU, KV,KW, KX,KY,KZ, 
06710+ KCOLON,KHYPHN , KLP, KRP»KSTAR, XTAB, KDOLLR, X))ELTA,KAPOST,KBACKS, 
06720+ KRET, I BLNKS, I BLNX, KDEC,KCOMMA, KCENT, LOWER, I TERM, IQNO,NOQ, 
06730+ IMAXAC, IMAXQC, ISTRSW, i.START,NOQUES, LI ST, LAST, IGETSW, I SAVEC 20 ) 
06740+ KEQUAL,NTAPE,KOLON, ICRSUMC 10, 1 0 ) ,NUMANS C 1 0 ) , I ANALY, I COPY, 

067 50+ I COUNT, I CROSS, I TAB, IANSWI 10),I0,X( 10),X2( 10),XCT( 10), IBEGA, 
06760+ NO, XMEAN ( 10) , XSDC 10), XMAXC 10), XM INC 10),N0DECS( 10), I D1 (12, 6), 
06770+ KZERO, KNINE, IMONTHC 22 ) , IHEADC 3, 1 60 ) , 

06780+ IOOC 10),KMASK< 10), JMASK( 10) 

06790 DATA I FILL0/033333333333333330000/ 

06800 N=1 
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06810 


1=0 

06820 


MM=1 

06830 


IDAY1 = KZERO 

06840 


IDAY2 = KZERO 

06850 


GO TO 145 

06860 

110 

1 = 1 + 1 

06870 


IF CIACI,4)-I TERM) 135,115,135 

06880 

115 

I DAT C 4 ) = I DAT f 1 ) 

06890 


I DAT C 5 ) = I DAT < 2 ) 

06900 


IF C I FLAG ) 125.120.125 

06910 

120 

I DAT C 6 ) = C KZERO+3 )* I SHFL 1 + C KZERO+ 1 > + 1 FILLO 

06920 


GO TO 130 

06930 

125 

I DAT C 6 ) = I DAT C 3 ) 

06940 

130 

IRET=4 

06950 


RETURN 

06960 

135 

IF ( I AC 1 , 4) -KHYPHN ) 137.140.137 

06970 

137 

IF CIACI,4)-KT) 190.138.190 

06980 

138 

1 = 1 + 1 

06990 

140 

MM=2 

07 000 


N=4 

07010 


IDAY1 = KZERO + 3 

07020 


IDAY2 = KZERO + 1 

07030 

145 

IFLAG=0 

07 040 

150 

1 = 1 + 1 

07050 


I CHAR=I AC 1.4) 

07060 


IF Cl CHAR - KNINE) 155. 155. 175 

07070 

155 

IF Cl CHAR - KZERO) 175. 160, 160 

07 080 

160 

I FLAG= I FLAG+ 1 

07090 


GO TO C 165, 170), I FLAG 

07100 

165 

IDAY1 = KZERO 

07110 


IDAY2=ICHAR 

07120 


GO TO 150 

07130 

170 

IDAY1=IDAY2 

07140 


1 DAY2= I CHAR 

07150 


1 = 1 + 1 

07160 


ICHAR=IAC 1,4) 

07170 

175 

K= I CHAR 

07180 


1 = 1 + 1 

07190 


L= IAC 1,4) 

07 200 


1 = 1 + 1 

07210 


I DATE1 = I SHFL 1*1 SHFL 1 *K+ 1 SHFL 1 *L+ I AC 1,4) 

07220 


DO 180 M= 1 , 22 

07 230 


M0=M 

07240 


IF C IDATE1-IM0NTHCM) ) 180,185,180 

07250 

180 

CONTINUE 

07260 


I RET=2 

07270 


RETURN 

07280 

185 

1 = 1 + 1 

07290 


K= I AC 1,4) 

07300 


1 = 1 + 1 

07310 


I DAT C N ) = I ABSC I SHFL1 *K) + I AC 1 , 4 ) + 1 FILLO 

07 320 


N=N+1 
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07330 I DAT C N ) =M0 

07340 N=N+1 

07350 I DAT C N > = I ABS C I DAY 1*1 SHFL 1 > + I DAY 2 + IFILLO 

07360 GO TO Cl 10., 130)., MM 

07370 190 IRET=3 

07380 RETURN 

07390 END 

07400 SUBROUTINE FINDS 

07410 COMMON IQNDEX, IANDEX, I DC 8* 4), IDATANC420), 

07420+ IDATAOC 300)# I SHFTLC 10), I SHFTRC 10),KALLC 7), IAC IS, 7 >, IQUC 6, 10), 
07430+ INEGC 10), IPRIMEC 10), IHNDEXC 10,10), IANOSZC 1 0 ) , ILHEADC 1 0 ) , 

07440+ IDATARC 10,2, 10), IDTSIZC 10, 1 0 ) , IELEMC 1 0, 10 ) , XDATARC 2,10), 

07450+ I CONN C 10) ,XSAVEC 10), IMAXQ, I FWAAC 120),LCQC 120), IDATC 6) , 

07 4 60+ IHDC 6, 2, 10),INDIVQC 10), IOUTMX, I COMP, INMAX, IMAXA, I CHAR, I CH, 

07 470+ IWD, I WDSIZ, JCHAR, JWD,KNO, I RET, I OUT, I SHFL 1 ,KA, KB,KC,KD,KE,KF, 
07480+ KG,KH,KI,KJ,KK,KL,KM,KN,KO,KP,KQ,KR,KS,KT,KU,KV,KW,KX,KY,KZ, 
07490+ KCOLON, KHYPHN, KLP, KRP, KSTAR, KTAB, KD0LLR,KDELTA, KAPOST, KBACKS, 
07500+ KRET, IBLNKS, I BLNK, KDEC, KCOMMA, KCENT,LOWER, I TERM, I QNO, NOS, 

07 510+ IMAXAC, IMAXQC, ISTRSW, I START,NOQUES,LI ST,LAST, IGETSW, I SAVEC 20 ) , 
07 520+ KEQUAL,NTAPE,KOLON, ICRSUMC 10, 1 0 ), NUMANSC 1 0 ) , I ANALY, I COPY, 
07530+ I COUNT, I CROSS, I TAB, IANSWC 10), IO,XC 10),X2C 10 ) ,XCTC 1 0 ) , I BEGA, 
07540+ NO,XMEANC 10 ) , XSDC 1 0 ) ,XMAXC 10),XMINC 10),N0DECSC 1 0 ) , I D1 C 1 2, 6) , 
07550+ KZERO,KNINE, IMONTHC 22), IHEADC 3, 1 60 ) , 

07560+ IOOC 10),KMASKC 10),UMASKC 10) 

07570 105 DO 115 I = 1 START, NOQUES 
07580 DO 110 J=l, IMAXQ 
07590 IQNDEX=I 

07600 IF CIQUC J, KNO) -IHEADC J, IQNDEX) ) 115,110,115 

07610 110 CONTINUE 

07620 GO TO 125 

07630 115 CONTINUE 

07640 DO 120 1=1,10 

07650 120 IHNDEXC I,KNO) =0 

07660 IRET= 1 

07670 IPRIMECKN0)=0 

07 680 RETURN 

07690 125 1=1 QNDEX- 1 

07700 LCQUES=LCQC I QNDEX) 

07710 IPRIMEC KNO ) =LCQUES 

07720 DO 140 J=5, I 

07730 K=LC0CJ) 

07740 IF CK-LCQUES) 130,140,140 

07750 130 IHNDEXC K, KNO) = J 

07760 KK=K+ 1 

07770 DO 135 KKK=KK, 10 

07780 135 IHNDEXCKKK,KN0)=0 

07790 140 CONTINUE 

07800 LSTART= 1 

07810 I=LCQUES-1 

07820 DO 165 L = 1,2 

07830 LL = 3-L 

07840 IF CIHDC 1 ,LL,KN0) - I BLNKS) 145,165,145 
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07850 145 DO 160 M=LSTART,I 

07860 N=IHNDEXCM,KN0) 

07870 IF CN) 1 50 , 1 60 , 150 

07880 150 DO 155 J=1,IMAXQ 

07890 IF CIHDC J,LL,KNO)-IHEADC J,N)) 160.155,160 

07900 155 CONTINUE 

07910 LSTART=M 

07920 GO TO 165 

07930 160 CONTINUE 

07940 I START=IQNDEX+ 1 

07950 GO TO 105 

07960 165 CONTINUE 

07970 IHNDEXCLCQUES,KNO)=IQNDEX 

07980 I RET=2 

07990 RETURN 

08000 END 

08010 SUBROUTINE FORMA 

08020 COMMON I QNDEX, I ANDEX, I DC 8, 4 ) , IDATANC420), 

08030+ I DATAOC 300 ) , I SHFTLC 1 0 ) , I SHFTRC 10), KALLC 7 ') , I AC 1 8, 7 ), I QUC 6, 10 ) , 
08040+ INEG C 10 ) , I PRIME( 10), IHNDEXC 10, 1 0 ) , I ANOSZ C 1 0 ) , ILHEADC 1 0 ) , 

08050+ I DATARC 10,2, 10),IDTSIZC 10, 10), IELEMC 10, 10),XDATAR(2, 10), 

08060+ I CONN ( 10) ,XSAVEC 10) , IMAXQ, IFWAAC 1 20 ),LCQC 120), IDATC 6 ) , 

08070+ IHDC 6,2, 10), INDIVQC 1 0 > , I OUTMX, I COMP, INMAX, IMAXA, I CHAR, I CH, 
08080+ IWD, IWDSIZ, JCHAR, JWD, KNO, I RET, I OUT, I SHFL1 ,KA, KB,KC, KD,KE,KF, 
08090+ KG , KH, KI , K J, KK, KL, KM, KN, KO, KP, KQ, KR, KS, KT, KU, KV, KW, KX, KY, KZ , 
08100+ KCOLON, KHYPHN, KLP, KRP, KSTAR, KTAB, KDOLLR, KDELTA, KAPOST, KBACKS, 
08110+ KRET, I BLNKS, I BLNK, KDEC, KCOMMA, KCENT, LOWER, I TERM, I QNO, NOQ, 

08 1 20+ IMAXAC, IMAXQC, I STRSW, I START, NOQUES, LI ST, LAST, I GETSW, I SAVEC 20 ) , 
08 1 30+ KEQUAL, NTAPE, KOLON, I CRSUM C 1 0, 1 0 ) , NUMANS ( 1 0 ) , I ANALY, I COPY, 
08140+ I COUNT, I CROSS, I TAB, IANSWC 10),I0,XC10),X2C 10),XCT( 10), IBEGA, 
08150+ NO.XMEANC 10),XSD( 10),XMAXC 10),XMINC 10),N0DECSC 10),ID1C12, 6), 
08160+ KZERO.KNINE, IM0NTHt22), IHEADC 3, 1 60 ) , 

08170+ I OOC 10), KMASK< 10), «JMASK( 10) 

08180 IF (JUD) 145,130,105 

08190 105 IF ( I OUT-LIST) 110,120,110 

08200 110 PRINT 115 

08210 115 FORMAT <22H INVALID OUTPUT DEVICE) 

08220 GO TO 135 

08230 120 CALL PRINT 

08240 GO TO 135 

08250 130 JWD= I OUTMX 

08260 135 DO 140 1=1, JWD 

08270 140 IDATAO< I )= I BLNKS 

08280 145 JWD=1 

08290 JCHAR=0 

08300 RETURN 

08310 END 

08320 SUBROUTINE FORMT 

08330 COMMON I QNDEX, I ANDEX, I D< 8, 4), IDATANC420), 

08340+ I DATAOC 300) , ISHFTL( 10), I SHFTR( 1 0),KALL( 7),1AC 18,7), I QUC 6,10), 
08350+ INEGC 10),IPRIMEC 10),IHNDEXC 10, 10), I ANOSZ C 10),ILHEADC 10), 

08360+ IDATARC 10,2, 10), IDTSIZC 10, 10), IELEMC 10, 10),XDATARC 2, 10), 
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08370+ ICOMN< 1 0 ) ,XSAVE< 10), IMAXQ, I FWAAC 1 20 ) , LCQ< 1 20 ) , I DATC 6 ) , 

08380+ IHDC 6/2, 10) , INDI VQC 10) , I OUTMX, I COMP, I MM AX, IMAXA, I CHAR, I CH, 
08390+ IWD, IWDSIZ, JCHAR, JWD,KNO, I RET, I OUT, I SHFL1 ,KA, KB, KC, KD,KE,KF, 
08400+ KG,KH,KI,KJ,KK,KL,KM,KN,KO,KP,KQ,KR,KS,KT,KU,KV,KV,KX,KY,KZ, 

08 41 0+ KCOLON, KHYPHN, KLP/KRP, KSTAR, KTAB, KDOLLR, KDELTA, KAPOST, KBACKS, 
08420+ KRET, IBLNKS, I BLMK, KDEC, KCOMMA, KCEMT, LOWER, I TERM, I QNO, MOQ, 
08430+ IMAXAC, IMAXQC, I STRSW, I START, MOQUES, LI ST, LAST, I GETSW, I SAVEC 20 ) , 
08440+ KEQUAL/NTAPE/KOLON, I CRSUMC 10, 10 ) , NUMANSC 1 0 ) , I ANALY, I COPY, 
08450+ I COUNT, I CROSS, I TAB, IANSW< 10) , I 0,XC 10 ),X2( 1 0 ) ,XCT( 1 0 ) , I BEGA, 
08460+ NO,XMEANC 10),XSDC 10),XMAX< 10),XMIN( 10),N0DECSC 10),ID1(12,6), 
08470+ KZERO,KNINE, IMONTHC 22), IHEADC 3, 1 60 ) , 


08480+ 


I00< 10), KMASKC 10), JMASKC 10) 

08490 


IF CIOUT-LIST) 110,105,110 

08500 

105 

I STRSW =3 

08510 

1 10 

IGETSW=1 

08520 


IWD=2 

08530 


ILIMIT = IMAXAC 

08540 


IPR0SE= 1 

08550 


LCORIG=LCQ< IQNDEX) 

08560 


IF CIQNDEX-4) 185,275,115 

08570 

115 

J=LCQC IQNDEX) 

08580 


CALL FORMA 

08590 


I CHAR= I BLNK 

08600 


IF CJ) 130,130,120 

08610 

120 

DO 125 1=1, J 

08620 

125 

CALL STRCH 

08630 

130 

IGETSVJ=2 

08640 


I VJD= 1 

08 650 


I CH=0 

08660 


I BLKCT=0 

08670 


DO 160 1=1,24 

08680 


CALL GETCH 

08 690 


IF ( I CHAR- 1 BLNK ) 140,135,140 

08700 

135 

I BLKCT= I BLKCT+ 1 

08710 


GO TO 160 

087 20 

140 

IF CIBLKCT) 155,155,145 

087 30 

145 

M=I CHAR 

087 40 


I CHAR= I BLNK 

087 50 


DO 150 J= 1,1 BLKCT 

087 60 

150 

CALL STRCH 

08770 


I 8LKCT=0 

08780 


I CHAR=M 

08790 

155 

CALL STRCH 

08800 

160 

CONTINUE 

08810 


IGETSW=3 

08820 


IWD=IFV7AA( IQNDEX) 

08830 


IF (IWD) 270,270,165 

08840 

165 

I =IQNDEX+ 1 

08850 

170 

ILWA= I FWAAC I ) 

088 60 


IF ( ILWA) 175,175,180 

08870 

175 

1 = 1 + 1 

08880 


GO TO 170 
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08890 180 ILIMIT=C ILWA-IWD)*IWDSIZ 

08900 IPR0SE=0 

08910 185 I CH=0 

08920 I C0DE=0 

08930 I DATE = 0 

08940 IMIDDT = 0 

08950 IBLKCT=0 

08960 DO 265 J=1#ILIMIT 

08970 CALL GETCH 

08980 IF CICHAR-KTAB) 195# 190,195 

08990 190 JWD=3 

09000 JCHAR = 4 

09010 IBLKCT=0 

09020 GO TO 265 

09030 195 IF CICHAR-KRET) 205# 200# 205 

09040 200 CALL FORMA 

09050 JMD= 1 

09060 JCHAR=0 

09070 GO TO 265 , 

09080 205 IF ( I CHAR- 1 BLNTK ) 214#210#214 

09090' 210 IBLKCT=IBLKCT+1 

09100 GO TO 265 

09110 214 IF < IPR0SEJ21 5# 215# 245 

09120 215 IF ( I DATE 5 216»216»219 

09130 216 IF f IMIDDT) 217#217#22? 

09140 217 IF (I CHAR - KEQUAL) 21 8# 226# 21 8 

09150 218 1DATE =1 

09160 219 IF CICHAR - KOLON) 230# 220# 230 

09170 226 IMIDDT = 1 

09180 GO TO 265 

09190 227 IF < IMIDDT - 7) 228#228#229 

09200 228 CALL STRCH 

09210 IMIDDT = IMIDDT + 1 

09220 GO TO 265 

09230 229 I DATE = 1 

09240 IF (IBLKCT) 219#219#221 

09250 221 M * /iCHAR 

09260 ICHAR = IBLNK 

09270 DO/222 I = 1# IBLKCT 

09280 222 CPJLX. STRCH 

09290 , IEHAR = M 

09300 999 FBLKCT = 0 

09310 / ho TO 219 

09320 220 / IPROSE= 1 

09330 IF (ICODE) 265#265#225 

09340 225 I CHAR=KRP 

09350 CALL STRCH 

09360 GO TO 265 

09370 230 IF UPROSE) 235# 235# 245 

09380 235 IF < ICODE) 240, 240# 245 

09390 240 M=ICHAR 

09400 ICODE=l 


50 



** "RETREVE" — RETRIEVAL PROGRAMS FOR MIMS SYSTEM 
08/05/71. 12.34.08. 


09410 


ICHAR=KLP 

09420 


CALL STRCH 

09430 


ICHAR=M 

09440 

245 

IF CIBLKCT) 260,260,250 

09450 

250 

M=ICHAR 

09460 


I CHAR= I BLNK 

09470 


DO 255 1=1, IBLKCT 

09480 

255 

CALL STRCH 

09490 


IBLKCT=0 

09500 


I CHAR=M 

09510 

260 

CALL STRCH 

09520 

265 

CONTINUE 

09530 

270 

IF (LOWER) 285,285,290 

09540 

27 5 

I GETSW= 1 

09550 


IWD=4 

09560 


ICH=IVDSIZ-2 

09570 


CALL GETCH 

09580 


I SUM = I CHAR - KZERO 

09590 


IF CISUM) 276,276,277 

09600 

276 

I CHAR = I BLNK 

09610 

277 

CALL STRCH 

09620 


CALL GETCH 

09630 


I SUM = I SUM + I CHAR - KZERO 

09640 


IF < I SUM) 278,278,279 

09650 

278 

I CHAR = I BLNK 

09660 

279 

CALL STRCH 

09670 


I WD=3 

09680 


ICH = IWDSIZ - 1 

09690 


CALL GETCH 

09700 


I D( 3,4 ) = IMONTHC I CHAR) 

09710 


IWD=3 

09720 


ICH=IWDSIZ-3 

09730 


DO 280 1=1,3 

09740 


CALL GETCH 

09750 

280 

CALL STRCH 

097 60 


IWD=2 

09770 


ICH=IWDSlZ-2 

09780 


CALL GETCH 

09790 


CALL STRCH 

09800 


CALL GETCH 

09810 


CALL STRCH 

09820 

285 

RETURN 

09830 

290 

I QNDEX=I ONDEX+ 1 

09840 


J=LCO( I QNDEX ) 

09850 


IF CLCORIG-J) 115,285,285 

09860 


END 

09870 


SUBROUTINE GETCH 


09880 COMMON IQNDEX, IANDEX, I DC 8, 4), IDATANC420), 

09890+ IDATA0C300), ISHFTLC 10), ISHFTRC 1 0 ) , KALLC 7 ) , I A( 1 8, 7 > , IQUC 6, 10), 
09900+ INEGC 10), IPRIMEC 10), IHNDEXC 10, 10), IANOSZC 10),ILHEAD( 10), 
09910+ IDATARC 1 0, 2, 1 0 ), I DTSIZ ( 10, 10), IELEMC 10, 10 ),XDATAR< 2, 10), 
09920+ IC0NN< 10),XSAVE< 10), IMAXQ, I FWAAC 1 20 ) , LCQC 1 20 ) , IDATC 6) , 
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09930+ IHD( 6,2* 10), INDIVQ( 10), IOUTMX, ICOMP, I MM AX, IMAXA, I CHAR, ICH, 
09940+ IWD, IWDSIZ, JCHAR, JWD,KNO, IRET, I OUT, I SHFL 1 ,KA,KB,KC, KD,KE,KF, 
09950+ KG,KH,KI,KJ,KK,KL,KM,KN,KO,KP,KQ,KR,KS,KT,KU,KV,KW,KX,KY,KZ, 
09960+ KCOLON, KHYPHN, KLP, KRP, KSTAR, KTAB, KDOLLR, KDELTA, KAPOST, KRACKS, 
09970+ KRET, I BLNKS, I BLNK, KDEC, KCOMMA, KCENT, LOWER, I TERM, I QNO, NOQ, 
09980+ IMAXAC, IMAXQC, I STRSW, I START, NOQUES, LI ST, LAST, IGETSW, I SAVE( 20 ) , 
09990+ KEQUAL,NTAPE,KOLON, ICRSUM( 1 0, 1 0 ) , NUMANS( 10 >, IANALY, I COPY, 
10000+ I COUNT, I CROSS, I TAB, IANSW( 10 ) , I 0,X( 10 ),X2( 10),XCT( 10>,IBEGA, 
10010+ N 0, XMEAN ( 1 0 ),XSD( 1 0 ) , XMAX( 10),XMIN( 1 0 ) ,N0DECS( 1 0 ) , ID1 ( 1 2, 6) , 
10020+ KZERO,KNINE, IMONTHC 22), IHEADC3, 1 60 )., 

10030+ I 00 ( 10), KM ASK C 10), JMASKC 10) 

10040 DIMENSION SLOT(IO) 

10050 TYPE INTEGER CHOICE, SLOT 
10060 DATA LASTCH / 1 0HXXXXXXXX9 / 

10070 DATA IBG / 0000077 / 

10080 ICH e ICH + 1 

10090 IF (ICH .LE. IWDSIZ) GO TO 5 

10100 ICH = 1 

10110 IWD = IWD + 1 

10120 5 CONTINUE 

10130 GO TO (10,20,30) IGETSW 

10140 10 CHOICE = ID( IWD, IQNDEX) 

10150 GO TO 40 

10160 20 CHOICE « I HEAD( IWD, IQNDEX) 

10170 GO TO 40' 

10180 30 CHOICE = IDATAN(IWD) 

10190 40 CONTINUE 

10200 IF (CHOICE .EQ. LASTCH) GO TO 50 

10210 LM = 0 

10220 DO 45 1=1,10 

10230 LM = LM + 6 

10240 SLOT(I) = I SHI FT( CHOICE, LM) 

10250 45 SLOT(I) = SLOT( I ) .AND. IBG 
10260 50 I CHAR = SLOT(ICH) 

10270 LASTCH = CHOICE 
10280 RETURN 

10290 END 

10300 SUBROUTINE HEAD IN 

10310 COMMON IQNDEX, IANDEX, ID(8,4), IDATAN(420), 

10320+ I DATA0( 300) , I SHFTL( 10 > , I SHFTR( 10) ,KALL( 7 ) , I A( 1 8,7 ), IQU( 6, 10) , 
10330+ INEG( 10 ) , IPRIME( 10), IHNDEX( 10, 10),IAN0SZ( 10),ILHEAD( 10), 

10340+ I DATAR( 10,2, 10), IDTSIZ( 10,10), I ELEM ( 10, 10 ) , XDATAR( 2, 10), 

10350+ I CONN ( 1 0 ) ,XSAVE( 10 ) , IMAXQ, I FWAA( 1 20 ),LCQ( 1 20 ) , I DAT( 6) , 

10360+ IHD( 6, 2, 10), INDI VQ( 10 ) , I OUTMX, I COMP, I NMAX, IMAXA, I CHAR, ICH, 
10370+ IWD, IWDSIZ, JCHAR, JWD,KNO, IRET, I OUT, I SHFL1 ,KA,KB,KC,KD,KE,KF, 
10380+ KG,KH,KI,KJ,KK,KL,KM,KN,KO,KP,KQ,KR,KS,KT,KU,KV,KW,KX,KY,KZ, 
10390+ KCOLON, KHYPHN, KLP, KRP, KSTAR, KTAB, KDOLLR, KDELTA, KAPOST, KBACKS, 
10400+ KRET, I BLNKS, I BLNK, KDEC, KCOMMA, KCENT, LOWER, I TERM, I QNO, NOQ, 
10410+ IMAXAC, IMAXQC, I STRSW, I START,NOQUES, LI ST, LAST, IGETSW, I SAVE( 20 ) , 
10420+ KEQUAL,NTAPE,K0L0N, ICRSUM( 10, 10 ),NUMANS( 1 0) , I ANALY, I COPY, 
10430+ I COUNT, I CROSS, I TAB, I ANSW( 10),I0,X(10),X2(10),XCT(10),I BEGA, 
10440+ N0,XMEAN( 10),XSD( 10),XMAX( 1 0 ) , XMIN ( 1 0 ) ,N0DECS( l 0 ) , I D1 (12,6), 
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110 

120 


130 


10450+ 
10460+ 
10470 105 
10480 
10490 
10500 
10510 
10520 
10530 
10540 
10550 
10560 
10570 
10580 
10590 
10600 
10610 
10620 
10630 
10640 
10650 
10660+ 
10670+ 

10 680+ 
10690+ 
10700+ 
10710+ 
10720+ 
10730+ 
10740+ 
10750+ 
10760+ 
10770+ 
10780+ 
10790+ 
10800+ 


KZERO,KNINE, I MONTH C 22), 


IHEADC 3,160), 

IOOC 10),KMASKC 10), JMASKC 10) 

CALL FORMA 
CALL FORMA 
DO 120 I = 1,4 
IQNDEX = I 
CALL FORMT 
I CHAR= I BLNK 
CALL STRCH 
CALL STRCH 
J = 2*1 

IF C J- JVD) 110,110,120 
CALL FORMA 
CONTINUE 
CALL FORMA 
DO 130 1=1,10 
ILHEADC I ) = 0 
RETURN 
END 

SUBROUTINE I NIT 

COMMON IQNDEX, IANDEX, IDC8, 4), IDATANC420), 

I DATAOf 300 ), I SHFTLC 10 ) , I SHFTRC 1 0 ) ,KALLC 7 > , I AC 1 8, 7 ) ,1 OUC 6, 1 0 ) , 
INEGC 10),IPRIMEC 10), IHMDEXC 10, 105,1 AMOSZC 10), ILHEADC 10), 
IDATARC 10,2, 10), IDTSIZC 10, 10 ) , I ELEMC 1 0, 10),XDATARC 2,10), 

I CONN CIO) , XSAVEC 10), IMAXQ, I FWAAC 120>,LCQC 120), IDATC 6>, 

IHD< 6,2, 10), INDI VQC 10), I OUTMX, I COMP, INMAX, IKAXA, I CHAR, I CH, 
IWD, IWDSIZ, JCHAR, JWD,KN0, IRET, IOUT, I SHFL1 ,KA,KB,KC,KD,KE,KF, 
KG, KH, KI , K J, KK, KL, KM, KN, KO, KP, KQ, KR, KS, KT, KU, KV, KW, KX, KY, KZ, 
KCOLON,KHYPHN,KLP,KRP,KSTAR,KTAB, KD0LLR,KDELTA, KAPOST, KBACKS, 
KRET, IBLNKS, I BLNK, KDEC, KCOMMA, KCENT, LOWER, ITERM, IQN0,N0Q, 
IMAXAC, IMAXQC, ISTRSW, I START, NOQUES, LI ST, LAST, IGETSW, I SAVE< 20) 
KEQUAL,NTAPE, KOLON, I CRSUMC 10, 1 0 ) ,NUMANS C 1 0 ) , I ANALY, I COPY, 

I COUNT, I CROSS, I TAB, I ANSVC 1 0 ) , I 0,X C 10),X2C 1 0 ),XCTC 10), I BEG A, 
NO,XMEANC 1 0 ) ,XSD( 10),XMAXC 10),XMIN( 10),N0DECS( 10),ID1C12, 6), 
KZERO,KNINE, IMONTHC 22) , IHEADC 3,160), 

IOOC 10), KMASKC 10), UMASKC 10) 


10810 DIMENSION IM0NC22) 

10820 DATA IM0N/01 20 1 1 6, 00 60 502, 0 1 50 1 22, 00 1 2022, 01 50 1 3 1 , 01 225 1 6, 
10830+ 0122514, 0012507 , 0230520,0170324, 0161726, 0040503, 0251 613/ 


10840 

IWDSIZ = 10 


10850 

IMAXA = 8 


10860 

IMAXQC = 24 


10870 

IMAXQ = 3 


10880 

IMAXAC = IMAXA * IWDSIZ 

10890 

I OUTMX = 300 

10900 

KNINE = 36 


10910 

KZERO = 27 


10920 

I SHFTLC 1 ) = 

1 

10930 

I SHFTLC 2) = 

2**6 

10940 

I SHFTLC 3) = 

2**12 

10950 

I SHFTLC 4) = 

2**18 

10960 

I SHFTLC 5) = 

2**24 
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10970 I SHFTLC 6> = 2**30 

10980 ISHFTLC7) = 2**36 

10990 I SHFTLC 8) = 2**42 

11000 I SHFTRC 3) = 2**42 

11010 1 SHFTRC 4) = 2**36 

11020 I SHFTRC 5) = 2**30 

11030 I SHFTRC 65 = 2** 24 

11040 I SHFTRC 7 ) = 2**18 

11050 I SHFTRC 8 > = 2**12 

11060 I SHFTRC 9) = 2**6 

11070 I SHFTRC 10) = 1 

11080 KM ASK C 1 ) =0 £ JMASKC 1 ) =55555555555555555555B 

11090 KMASKC 2)=77000000000000000000B £ JMASKC 2>=555555555555555555B 

11100 KMASKC 3)=77770000000000000000B £ JMASKC 3>=5555555555555555B 

11110 KMASKC 4) =77777700000000000000B £ JMASKC4)=55555555555555B 

11120 KMASKC 5 >=7777 77 7700000000000 OB £ JMASKC 5>=555555555555B 

11130 KMASKC 6)=77777777770000000000B $ JMASKC 6) =5555555555B 

11140 KMASKC7 )=77777777777700000000B £ JMASKC7)=55555555B 

11150 KMASKC 8)=77777777777777000000B $ JMASKC 8 > = 555555B 

11160 KMASKC 9) = 7777777777777777 OOOOB £ JMASKC 9 > =5555B 

11170 KMASKC 10)=77777777777777777700B £ JMASKC 1 0) =55B 

11180 IOOC 1 ) =000777 77 77 77777777777 

11190 IOOC 2 >=07700777 7777777777 77 7 

11200 IOOC 3)=077770077777777777777 

11210 IOOC 4 >=077777 700777 777 777 77 7 

11220 IOOC 5 >=07 7777 77 7 007 777 7 77777 

11230 IOOC 65=077777777770077777777 

11240 IOOC 7 >=077777777777700777777 

11250 IOOC 85=077777777777777007777 

11260 IOOC 9 >=077777777777777770077 

11270 IOOC 105=077777777777777777700 


11280 

IBLNK 

= 45 

11290 

I BLNKS 

= 1 OR 

11300 

KA 

= 

1 

11310 

KB 

= 

2 

11320 

KC 

= 

3 

11330 

KD 

=S 

4 

11340 

KE 

= 

5 

11350 

KF 

ss 

6 

11360 

KG 

= 

7 

11370 

KH 

ss 

8 

11380 

KI 

= 

9 

11390 

KJ 

= 

10 

11400 

KK 

= 

1 1 

11410 

KL 

ss 

12 

11420 

KM 

= 

13 

11430 

KN 

=2 

14 

11440 

KO 

=s 

15 

11450 

KP 

s= 

16 

11460 

KQ 


17 

11470 

KR 

= 

18 

11480 

KS 

= 

19 
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11490 

KT = 20 

11500 

KU = 21 

11510 

KV = 22 

11520 

KW = 23 

11530 

KX = 24 

11540 

KY = 25 

11550 

KZ = 26 

11560 

KRET = 53 

11570 

KHYPHN = 38 

11580 

KLP = 41 

11590 

KRP = 42 

11600 

KSTAR = 39 

11610 

KTAB = 50 

11620 

KEQUAL = 44 

11630 

KDOLLR = 43 

11640 

KDELTA =123 

11650 

KAPOST = 58 

11660 

KBACKS = 128 

11670 

KOLON = 51 

11680 

KCOLON = 51 

11690 

KCOMMA =46 

11700 

KDEC = 47 

11710 1111 

CONTINUE 

11720 

ISHFL1 = 2**6 

11730 

ISHFL2 = I SHFL 1**2 

11740 

DO 100 1=1,22 


11750 100 IMONTHI I ) = IMONO) 

11760 ITERfc = KSTAR 

11770 RETURN 

11780 END 

11790 SUBROUTINE STRCH 

11800 COMMON I QNDEX, I ANDEX, I DC 8, 4) , IDATAMC420), 

11810+ IDATA0C300),ISHFTL<10), I SHFTBC 1 0 ) ,KALLC 7 ) , I AC 1 8, 7 ) , I QUC 6, 10), 
11820+ INEGC 10),IPRIME< 10 ) , IHNDEXC 1 0, 10), IANOSZC 10),ILHEADC 10), 

11830+ IDATARC 1 0, 2, 1 0 ) , I DTSI ZC 10, 10), IELEMC 10, 10),XDATARC 2, 10), 

11840+ I CONN C 10 ) ,XSAVEC 10 ) , I MAXQ, I FWAAC 120) ,LCQC 120), IDATC6), 

11850+ IHDC 6,2, 10), INDIVQC 10 ) , I OUTMX, I COMP, INMAX, I MAX A, I CHAR, I CH, 

1 1860+ I WD, IWDSIZ, JCHAR, JWD, KNO, I RET, I OUT, I SHFL1 ,KA,KB,KC,KD,KE,KF, 
11870+ KG,KH,KI,KJ,KK,KL,KM,KN,KO,KP,KQ,KR,KS,KT,KU,KV/KW,KX,KY,KZ, 
11880+ KCOLON,KHYPHN,KLP, KEP, KSTAR, KTAB,KDOLLR, KDELTA,KAPOST, KBACKS, 

1 1890+ KRET, I BLNKS, I BLNK, KDEC, KCOMMA, KCEN T, LOWER, I TERM, I QNO, NOQ, 
11900+ IMAXAC, IMAXQC, I STRSW, I START, NOQUES, LI ST, LAST, IGETSW, I SAVE! 20), 
11910+ KEQUAL,NTAPE,KOLON, ICRSUMC 10, 10),NUMANSC 1 0 ) , I ANALY, I COPY, 
11920+ I COUNT, I CROSS, I TAB, IANSWC 10),I0,XC 10),X2( 10),XCT( 10),1BEGA, 
11930+ NO, XMEANC 10),XSDC 10)»XMAX( 10 ) , XMINC 1 0 ) , NODECSC 10), I DK1 2, 6), 
11940+ KZERO,KNINE, IMONTHC 22) , IHEADC 3, 1 60 ) , 

11950+ I 00 C 1 0 ) ,KMASK( 10), JMASKC 10) 

11960 DIMENSI ON FMTOO) 

11970 DATA FMT/7HCR1,R9), 10HC A1 , R1 , R8 ) , 1 OHC A2, R1 , R7 ) , 1 OHC A3, R1 , R6) , 
11980+ 10HCA4,R1,R5), 10HCA5,R1,R4), 1 OHC A6, R1 , R3 ) , 1 OHC A7, R1 , R2 ) , 

11990+ 1 OH (AS, R1 , R1 ) , 7H< A9, R1 ) / j 

12000 TYPE INTEGER CHOICE 
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12010 100 JCHAR = JCHAR + 1 

12020 107 IF C JCHAR - I WDSIZ ) 115.115.110 

12030 110 JCHAR =1 

12040 JWD = JWD + 1 

12050 115 L = 54 - 6*C JCHAR - 1) 

12060 KCHAR = ISHIFTC ICHAR.L) 

12070 GO TO ( 108, 208*308 ) ISTRSW 

12080 108 IAC JWD,KN0)=CIA< JWD.KNO). AND. IOOCJCHAR)). OR. KCHAR 
12090 GO TO 400 

12100 208 IQUC JWD, KN0)=CIQUC JWD.KNO). AND. I OOC JCHAR)). OR. KCHAR 
12110 GO TO 400 

12120 308 IF C JWD - I OUTMX) 1 20. 1 20. 9 10 

12130 120 I DATAOC JWD) = C I DATAOC JWD) .AND. I OOC JCHAR) ) • OR. KCHAR 
12140 400 RETURN 
12150 910 PRINT 911 

12160 911 FORMAT C 30H OUTPUT BUFFER EXCEEDED ) 

12170 CALL FORMA 
12180 JWD = 0 
12190 GO TO 110 
12200 END 

12210 SUBROUTINE TYPEN 

12220 COMMON IQNDEX, I ANDEX. I D< 8. 4) . IDATANC420). 

12230+ I DATAOC 300 ) . I SHFTL( 10 ) . I SHFTRC 10). KALL( 7 ) . IA( 1 8, 7 ) , I QUC 6, 1 0 ) , 
12240+ INEGC 10) . IPRIMEC 10>,IHNDEXC 10. 10). IANOSZC 10), ILHEADC 10), 

12250+ IDATARC 1 0, 2, 10), I DTSIZC 10, 10 ) , IELEMC 10, 1 0 ) .XDATARC 2, 10), 

12260+ ICONNC 10),XSAVE( 10 ) , IMAXQ, I FWAAC 1 20 ) ,LCQC 1 20 ) , I DATC 6 ) , 

12270+ IHDC6.2, 10),IND1VQC 10 ) , I OUTMX, ICOMP, INMAX, IMAXA, I CHAR, I CH, 

1 2280+ I WD, I WDSI Z, JCHAR, JWD, KNO, I RET, I OUT, I SHFL1 , KA, KB, KC, KD, KE, KF, 
12290+ KG.KH.KI ,KJ,KK,KL,KM,KN,KO,KP,KQ,KR,KS,KT,KU,KV,KW,KX,KY,KZ, 
12300+ KCOLON, KHYPHN, KLP, KRP.KSTAR, KTAB, KDOLLR, KDELTA, KAPOST, KBACKS, 
12310+ KRET, I BLNKS, I BLNK, KDEC, KCOMMA, KCENT, LOWER, I TERM, I QNO.NOQ, 
12320+ IMAXAC, IMAXQC, I STRSW, I START, NOQUES, LI ST, LAST, IGETSW, I SAVEC 20 ) , 
12330+ KEOUAL.NTAPE.KOLON, ICRSUMC 10, 10),NUMANSC 10), I AN ALY, I COPY, 
12340+ ICOUNT, ICROSS, ITAB, IANSW< 10), IO,X( 10 ) ,X2( 1 0 ) ,XCT( 10), IBEGA, 
12350+ NO.XMEANC 10),XSDC 10),XMAXC 10 ) .XMINCl 0 ) ,N0DECS< 10 ) , I D1 C l 2, 6) , 
12360+ KZERO.KNINE, IM0NTH< 22), IHEADC 3, 1 60) , 

12370+ I OOC 10),KMASK( 10), JMASKf 10) 

12380 COMMON /MODESW/ RETMODE 

12390 DATA IEND1 /10HEND OF REQ/, IEND2/5HUEST*/ 

12400 DATA N0NE/4HN0NE/ 

12410 DATA JALL/3HALL/ 

12420 IN0NE=N0NE-C IBLNK* I SHFTLC IWDSIZ-4) )+( ITERM*ISHFTLC IWDSIZ-4) ) 

12430 IALL=*JALL-CIBLNK*ISHFTLCIWDSIZ-3) ) + C I TERM* I SHFTL ( IVDSIZ-3) ) 

12440 ICT = 1 

12450 ISTRSW=1 

12460 IGETSW=3 

12470 IHYP=0 

12480 DO 50 1=1,20 

12490 50 IDATANCI) = I BLNKS 

12500 105 READ 1 10, < I DATANC I ), 1= 1 , 6) 

12510 JJ = 7 
12520 JP = 60 
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12530 110 FORMAT (6A10) 

12540 111 I CH=0 

12550 I WD= 1 

12560 IF (RETMODE .EQ. 6H REMOTE) GO TO 9950 

12570 PRINT 115, C I DA TAN (I), 1=1, 8) 

12580 115 FORMAT C7A10,A2) 

12590 9950 CONTINUE 

12600 IF ( IHYP) 120, 120.18S 

12610 120 CALL GETCH B 

12620 IF < I CHAR- I TERM ) 125,235,125 

12630 125 I CH=0 

12640 DO 130 J= 1 , IMAXA 

12650 130 I A( J,KN0)=I BLNKS 

12660 KALL(KN0)=1 

12670 IF CIDATAN(l) - INONE) 135, 225, 135 

12680 135 IF < I DATAN < 1 ) - 1 ALL ) 140,230,140 
12690 140 KALL(KN0)=0 

12700 IF ( IDATANI 1 > . EQ . 8HRESTART* > GO TO 250 

12710 IF < I DATAN ( 1 ) « EQ • 9HNEW FILE* ) GO TO 260 

12720 IF <IDATAN(1>-IEND1) 150,145,150 

12730 145 IF < I DATAN < 2) - 1 END2) 150,240,150 

12740 150 IF (KNO-4 ) 155,200,170 

12750 155 JWD=2 

12760 JCHAR=0 

12770 DO 165 K=1,IMAXAC 

12780 CALL GETCH 

12790 IF (ICHAR - I TERM) 160,166,160 

12800 160 CALL STRCH 

12810 165 CONTINUE 

12820 166 IF CKNO - 1) 167,167,169 

12830 167 DO 168 I = 1, IMAXA 

12840 168 ID1CI,ICT) *= IA(I,1) 

12850 ICT = ICT + 1 

12860 IF (ICHAR - ITERM) 196, 169, 196 

12870 169 IRET = 2 

12880 RETURN 

12890 170 IF (KNO-6) 175,155,184 

12900 175 DO 180 1=1,20 

12910 180 ISAVEC I ) = IDATAN( I ) 

12920 184 IHYP = 49 

12930 185 DO 195 K=1,JP 

12940 CALL GETCH 

12950 IHYP=IHYP+1 

12960 I DATAN C I H YP ) = ICHAR 

12970 IF ( I CHAR- I TERM ) 190,220,190 

12980 190 IF (IHYP-338) 195,215,215 

12990 195 CONTINUE 

13000 K = JJ+7 

13010 196 READ 197, ( IDATANC I ), I=JJ,K> 

13020 197 FORMAT (8A10) 

13030 JJ = JJ+8 
13040 JP = 80 
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13050 DO 198 K= 1 * 20 

13060 198 ISAVE(K) = IDATANCK) 

13070 GO TO 185 

13080 200 NDEX=1 

13090 DO 210 K=1 * IMAXAC s 

13100 CALL GETCH 

13110 IF < ICHAR-1BLNK) 205*210*205 

13120 205 IACNDEX*4)=ICHAR 

13130 NDEX=NDEX+1 

13140 IF < I CHAR- 1 TERM ) 210*220*210 

13150 210 CONTINUE 

13160 215 IRET“3 

13170 RETURN 

13180 220 IRET*2 

13190 RETURN 

13200 225 ISAVE< 1 )=NONE 

13210 GO TO 235 

13220 230 IA<2*KN0)=JALL 

13230 235 I RET=4 
> 13240 RETURN 

13250 240 I RET= 1 

13260 RETURN 

13270 250 IRET=5 

13280 RETURN 

13290 260 I BET =6 

13300 RETURN 

13310 END 

13320 SUBROUTINE MACHDT 

13330 COMMON IQNDEX* IANDEX* ID<8*4)* IDATANC420)* 

13340+ IDATAO< 300 ) * I SHFTLC 10 )* ISHFTRC 101 * KALLC 7 ) * IA< 18*7)# IQUC 6*10), 
13350+ INEG< 10)* I PHI ME C 1 0) * IHNDEXt 10* 10), IANOSZC 10), ILHEADf 10)* 

13360+ IDATAR< 10*2* 10)*IDTSIZC 10* iOl.IELEMJ 10, 10 ) *XDATAR< 2, 10) * 

13370+ I CONN C 10 ) *XSAVE( 10)* IMAXQ* I FWAA< 1 20 ) *LCQ( 1 20 ) * IDATC 6) * 

13380+ IHD< 6* 2* 1 0 ) * INDI VGK 1 0 ) * I OUTMX* I COMP* INMAX* IMAXA* I'CHAR* I CH* 
13390+ IWD* IWDSIZ* JCHAR* JWD*KN0* I RET* I OUT* I SHFL1 *KA*KB*KC*KD*KE*KF* 
13400+ KG*KH*KI*KJ*KK*KL*KM*KN*KO*KP*KQ*KR»KS*KT*KU*KV*kW*KX*KY*KZ* 
13410+ KCOLON* KHYPHN* KLP* KRP* KSTAR* KTAB* KDOLLR* KDELTA* KAP OST * KBACKS* ' 
13420+ KRET* IBLNKS* IBLNK*KDEC*KCOMMA*KCENT*LOWER* I TERM* IQNO*NOQ* 
13430+ IMAXAC* IMAXQC* I STRSW* I START* NOQUES* LI ST* LAST* I GETSW* I SAVEC 20 ) * 
13440+ KEQUAL* NTAPE* KOLON* I CRSUM C 1 0* 1 0 ) * NUMANS( 1 0 ) * I ANALY* I COPY* 
13450+ I COUNT, I CROSS* ITAB* IANSW< 10)* I0*XC 10)*X2< 10),XCT< 10)* IBEGA* 
13460+ N0*XMEAN< 10)*XSp( 10)*XMAXC 10)*XMIN< 10)*N0DECS( 10)* ID1 ( 1 2* 6>* 
13470+ KZER0*KNINE*IM0NTH(22), IHEADC 3* 1 60), 

13480+ I00( 10)*KMASK( 10)».JMASKC 10) 

13490 LCLIM=LCQ( IQNDEX) 

13500 LFWAA= I FWAAC IQNDEX) 

13510 XTOT = 0 

13520 IANS « 0 

13530 IGETSW=3 

13540 105 INDEX=IQNDEX+l 

13550 120 IANSZ1=IAN0SZ<KN0) 

13560 IWD=IFWAA( IQNDEX) 
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13570 KWD = IWD 

13580 I CH=0 

13590 IF ( IWD) 196# 196, 110 

13600 110 ILWA=IFWAA( INDEX) -1 

13610 IF (ILWA) 115,115*124 

13620 115 INDEX=INDEX+1 

13630 GO TO 110 

13640 124 IF (IANSZ1) 210,210,125 

13650 125 DO 195 IAN0=1 , IANSZ 1 

13660 NUMANS(KNO) = IANO 

13670 IWD = KWD 

13680 ICH =0 

13690 129 ISIZ = I DT S I Z ( I AN 0, KN 0 ) 

13700 IF (ISIZ) 210,210, 130 

13710 130 IF (ISIZ - 1000) 135,210,135 

13720 135 CALL GETCH 

13730 IF (IWD-ILWA) 140,140,195 

13740 140 IF (ICHAR- KOLON) 135,145,135 

13750 145 1=1 

13760 150 CALL GETCH 

13770 IF (IWD-ILWA) 155,155,195 

13780 155 IF ( I CHAR- 1 DATAR( I , I AN 0, KN 0 ) ) 160,190,160 

13790 160 IF ( I CHAR- I BLNK ) 165,150,165 

13800 165 IF ( I CHAR-KHYPHN ) 170,150,170 

13810 170 IF (ICHAR-KRET) 175,150,175 

13820 175 IF (ICHAR-KTAB) 180,150,180 

13830 180 XTOT=0 

13840 IF ( I CHAR- I DATAR( 1 , I ANO, KNO) ) 145,185,145 

13850 185 1=1 

13860 190 1=1+1 

13870 IF (I - ISIZ) 150,150,300 

13880 195 CONTINUE 

13890 196 IF (LFWAA) 310, 197, 310 

13900 197 NUMANS(KNO) = 0 

13910 200 J = IQNDEX + 1 

13920 I = LCQ(J) 

13930 IF (LCLIM-I) 205,315,315 

13940 205 IQNDEX = J 

13950 GO TO 105 

13960 210 IEXP=0 

13970 XT0T=0 

13980 IC0LON=0 

13990 215 CALL GETCH 

14000 IF (IWD-ILWA) 2215, 2215, 196 

14010 2215 IF (ICHAR - KEQUAL ) 218,216,218 

14020 216 DO 217 I = 1,7 

14030 217 CALL GETCH 

14040 GO TO 215 

14050 218 IF (ICHAR -KRP ) 219,275,219 

14060 219 IF ( I CHAR-KDOLLR) 220,215,220 

14070 220 IF (ICHAR-KCOMMA) 235,215,225 
14080 225 IF ( I CHAR- I BLNK) 230*215,230 

/ 


/ 

/ 

/ 
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14090 

230 

IF (ICHAR-KTAB) 235,215,235 

14100 

235 

IF (ICHAR-KRET) 240,215,240 

14110 

240 

IF Cl CHAR- KOLON) 245,400,245 

14120 

400 

IF C IANS) 410,410,280 

14130 

410 

I COLON * 1 

14140 


GO TO 215 

14150 

245 

IF (ICHAR-KDEO250, 255,250 

14160 

250 

IF CICOLON - 1) 251,460,251 

14170 

460 

IF CICHAR - KLP) 275,470,275 

14180 

470 

I COLON = 2 

14190 


GO TO 215 

14200 

251 

XCHAR a I CHAR - KZERO 

14210 


IF C I EXP) 265,265,260 

14220 

255 

IEXP=1 

14230 


GO TO 215 ' 

14240 

260 

XTOT=XTOT+XCHAR/ 1 0 . ** I EXP 

14250 


IEXPaIEXP+1 

14260 


GO TO 270 

14270 

265 

XTOT-XTOT* 1 0 . +XCHAR 

14280 

270 

IANS=1 

14290 


GO TO 215 

14300 

275 

IF ( IANS) 310,310,280 

14310 

280 

IF CIANSZ1) 305, 30S, 285 

14320 

285 

IF (XDATARC l.KNO) -XTOT) 290,300,295 

14330 

290 

IF C XDATARC 2, KNOJ-XTOT) 295,300,300 

14340 

295 

CONTINUE 

14350 


GO TO 196 

14360 

300 

CONTINUE 

14370 

305 

IRET=1 

14380 


XCTCKNO) = XCTCKNO) + 1 

14390 


XCKNO) = XCKNO) + XTOT 

14400 


X2CKN0) *> X2CKN0) + XTOT*XTOT 

14410 


IF (XTOT - XMAXCKNO)) 307,307,306 

14420 

306 

XMAXCKNO) = XTOT 

14430 

307 

IF (XTOT - XMINCKNO) > 308,320,320 

14440 

308 

XMINCKNO) = XTOT 

14450 


GO TO 320 

14460 

310 

XTOT = 0. 

14470 

315 

I RET=- 1 

1^480 

320 

XSAVEC KNO ) =XTOT 

4 4490 


IANSWCKNO) = IANS 

14500 


I = I EXP - 1 

14510 

325 

IF CNODECSCKNO) - I) 330,340,340 

14520 

330 

NODECSCKNO) = I EXP - 1 

14530 

340 

RETURN 

14540 


END 

14550 


SUBROUTINE WHAT 

14560 


DIMENSION ICHAINC10) 


14570 COMMON IGtNDEX, IANDEX, ID( 8, 4), IDATANC420), 

14580+ IDATA0C300),ISHFTLC10),ISHFTRC 10>,KALLC7>,IA< 18,7>,IQU< 6,10), 
14590+ INEGC 10 ), I PRIME? 10 ) , IHNDEXC 10. 10), IANOSZc 10), ILHEADC 10). 
14600+ IDATARC 10.2. 10),IDTSIZC 10. 10J.IELEMC 10. 10). XDATARC 2, 10), 
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14610+ I CONN < 10),XSAVE( 10)/ IMAXQ, I FWAAC 1 20 ),LCQ( 120), I DAT C 6) , 

14620+ IHDC 6, 2, 10 ) , INDI VQC 1 0 ) , I OUTMX, I COMP/ I MM AX/ I MAX A/ I CHAR/ I CH/ 
14630+ IWDz IWDSIZ, JCHAR, JWDzKNO, I RET/ I OUT/ I SHFL1 zKA/KB/KCzKD/KEzKFz 
14640+ KG,KH,KI,KJ,KK,KL,KM,KN,KO,KP,KQ,KR,KS,KT,KU,KV,KW,KX,KY,KZ, 
14650+ KCOLON, KHYPHNz KLP/ KRPz KSTARz KTABz KDOLLRz KDELTAz KAPOSTz KBACKS, 
14660+ KRET, IBLNKS, IBLNK,KDEC,KCOMMA,KCENT,LOWER, ITERM,IQNO,NOQ, 
14670+ IMAXACz IMAXQCz ISTRSW, ISTARTzNOQUES, LIST, LAST, I GET SUz I SAVE ( 20), 
14680+ KEQUALz NTAPE, KOLON z I CRSUM (10,10), NUMANS C 1 0 ) , I ANALY, I COPY, 
14690+ I COUNT, I CROSS, I TAB/ IANSWc 10),I0,X( 10)/X2C 10)/XCTC 10), IBEGA, 
14700+ NO/XMEANC 10),XSDC 10),XMAXC 1 0 ) zXMINC 1 0 ) ,N0DECSC 10), ID1 C 1 2, 6), 
14710+ KZEROzKNINE, IMONTH C 22 ) / IHEADC 3, 1 60 ) z 

14720+ I 00( 10 ) /KMASKC 10), JMASKC 10) 

14730 105 ICH = 49 

14740 I QN0=KN0 

14750 IGROUP= 1 

14760 IF (KNO-ICOMP) 110,110,125 

14770 110 ILEVEL=0 

14780 INEXTA=1 

14790 115 CONTINUE 

14800 IELEMC IQNO, IGROUP)=INEXTA 

14810 ILEVEL=ILEVEL+1 

14820 I CHAIN Cl LEVEL )*INEXTA 

14830 IGROUP=ICHAINC ILEVEL) 

14840 IF CINEXTA-NOQ) 120,120,300 

14850 120 INEXTA=INEXTA+1 

14860 125 IBLKSW=0 

14870 130 JWD=1 

14880 UCHAR=0 

14890 135 CALL GETWH 

14900 GO TO < 320, 265,115,1 40, 145, 145, 200, 225,1 90, 175, 200 ) , I RET 

14910 140 ILEVEL=ILEVEL- 1 

14920 I GR0UP=ICHAIN< ILEVEL) 

14930 I BLKSW= 1 

14940 GO TO 130 

14950 145 IF CIBLKSW) 200,200,150 

14960 150 CALL CKWHAT 

14970 GO TO (320,265,115,140,160,155,200), IRET 

14980 155 1=1 

14990 GO TO 165 

15000 160 I=-l 

15010 165 IQN0=IQN0+1 

15020 IF (KNO-ICOMP) 170,170,125 

15030 170 I CONN C IGROUP) = ICONN( IGROUP) + I 

15040 GO TO 125 

15050 175 IF C IHDC 1,2, KNO)-IBLNKS) 310/180,310 

15060 180 DO 185 111=1,6 

15070 IHDC 111,2,1 QNO ) = IHDC 1 1 1 , 1 , I QNO) 

15080 IHDC 1 1 1 , 1 , I QNO ) = IQUC III,I QNO) 

15090 I QUc III, I QNO ) =1 BLNKS 

15100 185 CONTINUE 

15110 GO TO 125 

15120 190 IF (JCHAR) 135,135,195 
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15130 195 I BLKSW= 1 
15140 GO TO 205 

15150 200 IBLKSW=0 

15160 205 ISTRSW*=2 

15170 IF (IQNO-ICOMP) 210*210*215 

15180) 210 I ELEMt I QNO* I GROUP ) = 1 

15190 215 KN0=IQN0 , 

15200 CALL STRCH 

15210 GO TO 135 . 

15220 220 INEG(1QN0)=-1 / 

15230 225 CALL GETWH 

15240 IF ( I CHAR- 1 BLNK ) 230*225*230 I 

15250 230 IF CICHAR - KZERO) 240* 235* 235 I 

15260 235 I F i 1 CHAR - KNINE) 245* 245* 240 

15270 240 x I F I CHAR-KDEC ) 260*245*260 
15280 245 CALL WHCODE 

15290 GO- TO (320*265*115*140*160*155*250)* I RET 

15300 250 PRINT 255 

15310 255 FORMAT C40H ILLEGAL CHAR FOLLOWING CODED DATA 
15320 GO TO 330 

15330 260 CALL WHPROS 

15340 GO TO (320*265*115,140*160*155*220)* IRET 

15350 265 IF (IGROUP-1) 270*280*270 
15360 270 PRINT 275 

15370 275 FORMAT ( 26H PARENTHESIS COUNTED WRONG) 

15380 GO TO 330 

15390 280 IF (KNO-ICOMP) 285,285*290 

15400 285 I COMP** IQNO 

15410 GO TO 295 

15420 290 LAST=IQNO 

15430 295 IRET=2 

15440 RETURN 

15450 300 PRINT 305 

15460 305 FORMAT ( 29H TOO MANY SETS OF PARENTHESIS) 

15470 GO TO 330 . ; 

15480 310 PRINT 315 

15490 315 FORMAT (19H TOO MANY MODIFIERS) 

15500 , GO TO- 330 / 

15510 320 PRINT 325 / 

15520 325 FORMAT ( 30H DATA CANNOT EXCEED 288 CHARS ) 

15530 330 I RET** 1 

15540 RETURN 

15550 END 

15560 SUBROUTINE CKWHAT 

15570 COMMON IQNDEX, IANDEX* ID< 8* 4) , I DAT AN ( 420 ) * 

15580+ IDATAOC 300) * I SHFTLC 10)* I SHFTRUO ) *KALL( 7 ) » IAC 1 8* 7 )* IQU(6* 10)* 
15590+ INEGC 10),IPRIME( 10)*IHNDEXC 10* 1 0 ) * IANOSZC 10 ) * ILHEADC 10) » 

15600+ I DATARC 10*, Si 1 0 ) * IDTSIZ ( 1 0* 1 0 ) * I ELEM (10*10)* XDATARC 2*10)* 

15610+ I CONN ( 10 ) »XSAVE( 10 ) * IMAXQ* I FWAAC 1 20 )*LCQ( 120)* IDAT( 6) * 

15620+ IHDC 6*2, 10)*INDIVQ( 10) * I OUTMX* I COMP* INMAX* IMAXA* I CHAR* ICH* 
15630+ IWD* IWDSIZ, JCHAR* JWD*KN0* IRET* I OUT* I SHFL1 *KA*Kfe*KC*KD*KE*KF* 
15640+ KG*KH*KI*KJ*KK*KL*KM*KN*K0*KP*KQ*KR*KS*KT*KU*KV*K1‘;*KX*KY*KZ* 


/ 

/ 
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15650+ KCOLON » KHYPHN , KLP, KRP , KSTAR, KTAB, KDOLLR, KDELTA, KAPOST, KBACKS, 
15660+ KRET, IBLNKS, I BLNK, KDEC,KCOMMA,KCENT, LOWER, 1TERM, I QNO.NOQ, 
15670+ IMAXAC, IMAXQC, ISTRSW, I START, NOQUES.LIST, LAST, IGETSW, I SAVEC 20 ) , 
15680+ KEQUAL,NTAPE,KOLON, ICRSUMC 10. 10),NUMANS( 10), IANALY, ICOPY, 
15690+ I COUNT, I CROSS, I TAB, IANSWC 10),I0,X(10),X2C 10),XCTC 10),IBEGA, 
15700+ N0,XMEANC10),XSD( 10>,XMAXC 1 0 ) , XMINC 1 0 ),NODECSC 1 0 ) , I D1 C 1 2, 6 ) , 
15710+ KZERO.KNINE, IMONTHC 22 ), IHEADC 3, 1 60 ) , 

15720+ IOOC 10), KMASKC 10), JMASKC 10) 

I 15730 I CUR= I CH 

| 15740 IHOLD=ICHAR 

15750 GOTO (150,150,150,150,105,120,150,140,140,140,140), IRET 

15760 105 CALL GETVH 

15770 IF CICHAR-KN) 140,110,140 

15780 110 CALL GETVH 

i 15790 IF CICHAR-KD) 140,115,140 

i 15800 115 CALL GETWH 

15810 IRET=5 

; 15820 GO TO 130 

\ 15830 120 CALL GETWH 

15840 IF CICHAR-KR) 140,125,140 

\ 15850 125 CALL GETWH 

115860 I RET= 6 

115870 130 IF ( I CHAR- I BLNK ) 135,150,135 

\15880 135 IF ( I CHAR-KLP) 140,145,140 

45890 140 I CH= I CUR 

15900 ICHAR=IH0LD 

1\5910 I RET=7 

15920 RETURN 

15930 145 I CH=ICH— 1 

15940 150 RETURN 

15950 END 

15960 SUBROUTINE GETWH 

15970 DIMENSION IWHC10) 

15980 COMMON I QNDEX, I ANDEX, I DC 8, 4) , IDATANC420), 

15990+ IDATAOC 300),ISHFTLC 10), ISHFTRC 10 ),KALLC 7 ), IAC 18,7), I QUC 6, 10), 
16000+ INEGC 10), IPRIMEC 10),IHNDEXC 10, 10), IANOSZC 10), ILHEADC 10), 

16010+ IDATARC 10,2, 10),IDTSIZC 10, 10),IELEMC 10, 10),XDATAR(2, 10), 

16020+ I CONN C 10),XSAVE( 10 ) , IMAXQ, I FWAAC 1 20 ),LCQC 120), IDATC 6), 

16030+ IHDC 6,2, 10), INDIVQC 10), IOUTMX, ICOMP, INMAX, IMAXA, I CHAR, ICH, 
16040+ IWD, IWDSIZ, JCHAR, JWD.KNO, IRET, I OUT, ISHFL1 ,KA,KB,KC,KD,KE,KF, 
16050+ KG,KH,KI,KJ,KK,KL,KM,KN,KO,KP,KQ,KR,KS,KT,KU,KV,KW,KX,KY,KZ, 

1 60 60+ KCOLON, KHYPHN, KLP, KRP, KSTAR, KTAB, KDOLLR, KDELTA, KAPOST, KBACKS, 
16070+ KRET, I BLNKS, I BLNK, KDEC, KC OMMA, KCENT, LOWER, I TERM, I QN 0, NOQ, 
16080+ IMAXAC, IMAXQC, I STRSW, I START, NOQUES, LI ST, LAST, IGETSW, I SAVEC 20 ) , 
16090+ KEQUAL,NTAPE,KOLON, ICRSUMC 10,1 0 ),NUMANS( 10), IANALY, ICOPY, 
16100+ I COUNT,' I CROSS, I TAB, IANSWC 1 0 ), I 0,X( 1 0) ,X2C 10),XCTC 10),IBEGA, 
16110+ NO.XMEANC 10),XSDC 10),XMAXC 10 ) ,XMIN( 1 0 ),NODECSC 10) , ID1 (12,6), 
16120+ KZERO.KNINE, IMONTHC 22), IHEADC 3, 1 60 ),, . 

16130+ • IOOC 10),KMASKC 10), JMASKC 10) 

16140 105 ICH=ICH+1 

16150 ICHAR = IDATANCICH) 

16160 IF C ICH- 3 38 ) 115,115,110 
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16170 110 IRET=1 

16180 RETURN 

16190 115 IF CICH-50) 125, 120,125 

16200 120 IWHC 2) = ITERM 

16210 IWHC3)=KLP 

16220 IWHC 4>=KRP 

16230 IVHC5)=KA 

16240 IWHC 6)=K0 

16250 IWHC7)=KN 

16260 IWHC8)=KC0L0N 

16270 IWHC9)=IBLNK 

16280 IWHC 10)=KCOMMA 

16290 125 DO 130 1=2,10 

16300 IR£T=I 

16310 IF C ICHAR-IWHC I ) ) 130,140,130 

16320 130 CONTINUE 

16330 IF CICHAR - KRET) 135,105,135 

16340 135 IRET=1 1 

16350 140 RETURN 

16360 END 

16370 SUBROUTINE WHPROS 

16380 COMMON IQNDEX, IANDEX, IDC 8, 4), IDATANC420), 

16390+ IDATAOC 300) , I SHFTLC 10 ), ISHFTRC 10 ) ,KALLC 7 ) , I Ac 18, 7 ), IQUC 6, 10), 
16400+ INEGC 10), IPR1MEC 10), IHNDEXC 10, 10),IAN0SZC 10), ILHEADC 10), 

16410+ IDATARC 10, 2, 10 ) , IDTSIZC 10, 10), IELEMC 10, 10),XDATAR( 2, 10), 

16420+ I CONNC 1 0 ) ,XSAVEC'l 0 ), IMAXQ, I FWAAC 1 20 ) ,LCQ< 1 20 ) , I DAT C 6 ) , 

16430+ IHDC 6, 2, 1 0 ) , INDI VQC 1 0 ) , I OUTMX, I COMP, I NMAX, I MAX A, I CHAR, I CH, 
16440+ IWD, IWDSIZ, JCHAR, JWD,KNO, IRET, I OUT, I SHFL1 ,KA,KB,KC,KD,KE,KF, 
16450+ KG,KH,KI,KJ,KK,KL,KM,KN,KO,KP,KQ,KR»KS,KT,KU,KV,KW,KX,KY,KZ, 

1 6460+ KCOLON, KHYPHN, KLP, KRP, KSTAR, KTAB, KDOLLR, KDELTA, KAPOST, KBACKS, 
16470+ KRET, I BLNKS, I 8LNK, KDEC, KCOMMA, KCENT, LOWER, I TERM, I QNO, NOQ, 

1 6480+ IMAXAC, IMAXQC, I STRSW, I START, NOQUES, LI ST, LAST, IGETSW, I SAVEC 20 ) , 
16490+ KEQUAL,NTAPE,KOLON, ICRSUMC 10, 10),NUMANSC 10),IANALY, ICOPY, 
16500+ ICOUNT, I CROSS, I TAB, I AN SW C 10), IO,X< 10),X2C 10),XCTC 10), IBEGA, 
16510+ N0,XMEANC 10),XSD< 10),XMAXC 10),XMINC 10),N0DECSC 10 ) , ID1 C 1 2, 6), 
16520+ KZERO,KNINE, IM0NTHC22), IHEADC 3, 160), 

16530+ IOOC 10),KMASKC 10), JMASKC 10) 

16540 IAN0=1 

16550 105 IBLKSW=0 

16560 I DCH= 1 

16570 IANOSZC lGNO)=IANO 

16580 110 GO TO C 1 70, 170, 170, 170, 1 1 5, 1 15, 1 25, 150, 180, 175, 1 50), IRET 
16590 115 IF CIBLKSW) 150,150,120 

16600 120 CALL CKWHAT 

16610 GO TO C170, 170, 170, 170, 170, 170, 150), IRET 

16620 125 ICURR=ICH 

16630 IF CIDCH-1) 150,130,150 

16640 130 CALL GETWH 

16650 IF CICHAR-KO) 145,135,145 

16660 135 CALL GETWH 

16670 IF CICHAR-KT) 145,140,145 

16680 140 CALL GETWH 


64 



** "RETREVE" — RETRIEVAL PROGRAMS FOR MIMS SYSTEM 
08/05/71. 12.34.08. 


16690 


IRET=7 

16700 


IF ( I CHAR- I BLNK ) 145,170,145 

16710 

145 

ICH=ICURR 

16720 


I CHAR=KN 

16730 

150 

CONTINUE 

16740 

155 

I0TSIZC IANO, I QNO ) = I DCH 

16750 


I BLKSW=0 

16760 

160 

I DATARC I DCH, I ANO, I QN 0 ) = I CHAR 

16770 


IDCH=IDCH+1 

16780 

165 

CALL GETWH 

16790 


GO TO 110 

16800 

170 

RETURN 

16810 

175 

CALL GETWH 

16820 


IAN0=IAN0+1 

16830 


GO TO 105 

16840 

180 

IF < I DCH- 1 ) 165,165,185 

16850 

185 

IBLKSW=1 

16860 


GO TO 160 

16870 


END 

16880 


SUBROUTINE WHCODE 


16890 COMMON I QNDEX, IANDEX, I DC 8 , 4 ) , IDATANC420), 

16900+ I DATA0<. 300 > * I SHFTLc 10 ) , I SHFTRt 1 0 ) ,KALLi 7 ) , I At 18, 7 > , I QUl 6, 10 ) , 
16910+ INEGC 10),IPRIMEC 10),IHNDEX( 10, 10 ), IANOSZi 10), ILHEADl 10), 

16920+ IDATARC 10,2, 10),IDTSIZ( 10, 10),IELEMC 10, 1 0 ) ,XDATARc 2, 10), 

16930+ I CONN <. 10 ) ,XSAVEl 1 0 ) , IMAXQ, I FWAAll 20 ) , LCGK 1 20 ) , I DAT<- 6) , 

16940+ IHDC 6, 2, 10 ), 1ND1 VQC 10), I OUTMX, I COMP, INMAX, IMAXA, I CHAR, I CH, 
16950+ IWD, IWDSIZ, JCHAR, JWD,KN0, IRET, I OUT, I SKFL1 ,KA,KB,KC, KD,KE,KF, 
16960+ KG,KH,KI,KU,KK,KL,KM,KN,KO,KP,KQ,KR,KS,KT,KU,KV,KW,KX,KY,KZ, 
16970+ KCOLON, KHYPHN, KLP, KRP, KSTAR,KTAB, KDOLLR, KDELTA, KAPOST, KBACKS, 
16980+ KRET, I BLNKS, I 3LWK,KDKC,KC0MMA,KCENT, LOWER, I TERM, I QNO, NOQ, 
16990+ I MAX AC, IMAXQC, I STRSW, ISTART,NOQUES,LI ST, LAST, IGETSW, I SAVEC 20 ) , 
17000+ KEQUAL,NTAPE,KOLON, ICRSUM< 10, 10 ) ,NUMANSi 10) , IANALY, I COPY, 
17010+ I COUNT, I CROSS, I TAB, I ANSVK 10 ) , I 0,X C 1 0 ) ,X2<. 10),XCT<. 10), IBEGA, 
17020+ NO,XMEAN< 10),XSD( 10),XMAXl 10),XMIN(. 10>,N0DECS<. 10),ID1..12,6), 
17030+ KZERO,KNINE, IMONTHi 22), IKEAD*. 3, 1 60 ) , 


17040+ 


I OOv 10), KMASKt 10), JMASKv 1 0 ) 

17050 


ILOWKI » 1 

17060 


IDTSIZ<. 1,IQN0)=1000 

17070 

105 

XDATA=0 

17080 


XDATAS=0 

17090 


IEXP=0 

17100 

110 

IQUCH=ICHAR 

17110 

115 

IF <.IG1UCH - KZERO) 125, 120, 120 

17120 

120 

IF (.IQUCH - KNINE) 180, 180, 125 

17130 

125 

IF ..IQUCH- KHYPHN) 130,145,130 

17140 

130 

IF «. I QUCK-KT ) 155,135,155 

17150 

135 

CALL GETWH 

17160 


IF (ICKAR-KO) 175,140,175 

17170 

140 

IL0WHI=2 

17180 


XDATARv 1, IQNO)=XDATA:<XDATAS 

17190 


CALL GETWH 

17200 


GO TO 105 
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17210 145 IF CXDATAS) 140,150*140 

17220 150 XDATAS=-1 

17230 GO TO 20 O 5 

17240 155 IF CIQUCH-KDOLLR) 160,200,160 

17250 160 IF CIQUCH-KCENT) 165,200,165 

17260 165 IF CIQUCH-KTAB) 170,200,170 

17270 170 IF C I CHAR-KDEC ) 172,225,172 

17280 172 IF CIQUCH-IBLNK) 185,200,185 

17290 175 ICHAR=KT 

17300 I CH= I CH- 1 

17310 GO TO 185 

17320 180 XCHAR = ICHAR - KZERO 

17330 IF < I EXP) 185,185,230 

17340 185 XDATA=XDATA* 10. +XCHAR 

17350 190 IF CXDATAS) 200,195,200 

17360 195 XDATA5= 1 

17370 200 CALL GETWH 

17380 GO TO C21Q, 210, 185,210,205,205, 185, 185,200,200, 1 10), IRET 

17390 205 CALL CKWHAT 

17400 GO TO <210,210,210,210,210,210,185), IRET 

17410 210 GO TO <215,220), ILOWHI 

17420 215 XDATARC 1, IQNO) =XDATA*XDATAS 

17430 220 XDATARC 2, IQNO)=XDATA*XDATAS 

17440 IANOSZC IQN0)=1 

17450 RETURN - 

17460 225 IEXP=1 

17470 GO TO 200 

17480 230 XDATA=XDATA+XCHAR/10.**IEXP 

17490 ' IEXP=I EXP+ 1 

17500 GO TO 190 

17510 END 

17520 SUBROUTINE PFLFIX 

17530 COMMON IQNDEX, IANDEX, IDC 8, 4), IDATANC420), 

17540+ I DATAOC 300 ) , I SHFTL ( 10), ISHFTRC 10),KALL<7), IAC 18,7 ), IQUC 6, 10), 
17550+ INEGC 10 ), IPRlMEC 10 ) , IHNDEXC 10, 10 ) , IANOSZC 10 ) , ILtHEADC 10 ) , 

17560+ IDATARC 10,2, 10),IDTSIZ< 10, 10),IELEMC 10, 10), XDATARC 2, 1 0 ) , 

17570+ I CONN < 10),XSAVEC 10) , IMAXQ, IFWAAC 1 20 ),LCQ< 120), I DAT C 6) , 

17580+ II-lDC 6, 2, 10), INDI VQC 10 ), I OUTMX, I COMP, INMAX, IMAXA, ICHAR, ICH, 

17 590+ IWD, IWDSIZ, JCHAR, JWD,KNO, I RET, I OUT, I SHFL1 ,KA, KB,KC, KD,KE,KF, 
17600+ KG,KH,KI,KJ,KK,KL,KM,KN,KO,KP,KQ,KR,KS,KT,KU,KV,KW,KX,KY,KZ, 
17610+ KCOLON, KHYPHN, KLP, KRP, KSTAR, KTAB, KDOLLR, KDELTA, KAPOST,KBACKS, 
17620+ KRET i I BLNKS, IBLNK,KDEC,KCOMMA,KCENT,LOWER, ITERM, IQN0,N0Q, 
17630+ IMAXAC, IMAXQC, ISTRSW, ISTART,NOQUES,LIST,LAST, IGETSW, I SAVEC 20 ) , 
17640+ KEQUAL,NTAPE,K0L0N, ICRSUMC 10, 10),NUMANSC 10 ) , IANALY, ICOPY, 

1 7 650+ I COUNT, I CROSS, I TAB, I ANSW C 1 0 ) , I 0, X C 1 0 ) ,X2 C 1 0 ) , XCTC 1 0 ) , I BEGA, 
17660+ NO,XMEANC 10),XSD< 10),XMAXC 10),XMINC 10),NODECSC 10), ID1 C 1 2, 6) , 
17670+ KZERO,KNINE, IM0NTHC22), IHEADC 3, 160), 

17680+ I OOC 10 ),KMASKC 10 ), JMASKC 10) 

17690 NOPLAC =9 ' . 

17700 NODEC = NODECSCKNO) 

17710 IF C NODEC ) 1,1,2 

17720 1 NOINT = NOPLAC 
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17730 
17740 
17750 
17760 
17770 
17780 
17790 
17800 
17810 
17820 
17830 
17840 
17850 
17860 
17870 
17880 
17890 
17900 
17910 
17920 
17930 
17940 
17950 
17960 
17970 
17980 
17990 
18000 
18010 
18020 
18030 
18040 
18050 
18060 
18070 
18080 
18090 
18100 
181 10 
18120 
18130 
18140 
18150 
18160 
18170 
18180 
18190 
18200 
18210 
18220 
18230 
18240 


GO TO 3 

2 NOINT = NOPLAC - NODEC - 1 

3 CONTINUE 
ISTRSW = 3 

I CHAR = IBLNK 
CALL STRCH 
CALL STRCH 

IF ( IANOSZ< KNO) ) 420. 420. 410 
410 IF < INDIVQCKNO) ) 280. 280. 10 
420 IF CIANSWCKNO)) 280. 280. 10 
10 IF <XSAVECKNO>) 15.310.20 
15 I CHAR = KHYPHN 
CALL STRCH - 
XSAVECKNO) = -XSAVECKNO) 

NOINT = NOINT - 1 
20 NUNUM = XSAVECKNO) 

XNUNUM=NUNUM 

XNUDEC = XSAVECKNO) - XNUNUM 
IANS=0 

I FCNUNUM- 10**N0INT) 30. 250. 250 
30 DO 80 J=l. NOINT 
K=N0INT-J 
I CHAR=NUNUM/10**K 
NUNUM=NUNUM- I CHAR* 1 0**K 
I ANS= IANS+ 1 CHAR 
I CHAR = I CHAR + KZERO 
I FC I ANS )40. 40. 50 
40 I CHAR= I BLNK 
CALL STRCH 
GO TO 80 
50 CALL STRCH 
80 CONTINUE 

IF CNODEC ) 340.340.90 
90 I CHAR = KDEC 
CALL STRCH 

XNUDEC = XNUDEC+ .5/10. **N0DEC 
100 DO 110 K=l. NODEC 
XN0=XNUDEC* 1 0. **K 
I CHAR=XNO 
CHAR=I CHAR 

I CHAR = I CHAR + KZERO 
CALL STRCH 

XNUDEC=XNUDEC-CHAR/ 10 . **K 
110 CONTINUE 
GO TO 340 
250 I CHAR = KX 
GO TO 290 
280 ICHAR=IBLNK 
290 DO 300 K= 1 .NOPLAC 
CALL STRCH 
300 CONTINUE 
GO TO 340 
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18250 310 I CHAR= I BLNK 

18260 M=N0INT-1 

18270 DO 320 K=l»M 

18280 CALL STRCH 

18290 320 CONTINUE 

18300 I CHAR = KZERO 

18310 CALL STRCH 

18320 IF (NODEC) 321. 340. 321 

18330 321 I CHAR = KDEC 

18340 CALL STRCH 

18350 I CHAR = KZERO 

18360 DO 330 K=l, NODEC 

18370 CALL STRCH 

18380 330 CONTINUE 

18390 340 CONTINUE 

18400 RETURN 

18410 END 

18420 SUBROUTINE PRINT - 

18430 COMMON IQNDEX. IANDEX, ID( 8.4), IDATAN(420), 

18440+ I DATAOC 300 ) , I SHFTL ( 1 0 ) , I SHFTBC 10), HALL C 7 ) , I AC 1 8, 7 ) , I QUC 6, 1 0 ) , 
18450+ INEGC 10),IPRIMEC 10 ), IHNDEXC 10, 10 >, I ANOSZt 10),ILHEADC 10), 

18460+ IDATARC 1 0, 2, 10 ) , I DTSIZC 10, 10),IELEMC 10,10),XDATARC 2, 10), 

18470+ I CONNC 10 ) ,XSAVE< 10 ) , IMAXQ, IFWAAC 1 20 ) , LCQC 1 20 ) , I DAT C 6 ) , 

18480+ IHDC 6,2, 10), INDIVQC 10) , I OUTMX, I COMP, INMAX, IMAXA, I CHAR, ICH, 
18490+ I VD, IWDSIZ, JCHAR, JWD, KNO, 1 RET, I OUT, I SHFL 1 , KA, KB.KC, KD,KE, KF, 
18500+ kg,kh,ki,kj,kk,kl,km,kn,ko,kp,kq,kr,ks,kt,ku,kv,kw,kx,ky,kz, 
18510+ KCOLON, KHYPHN, KLP, KRP, KSTAR, KTAB, KDOLLR, KDELTA, KAPOST, KBACKS, 
18520+ KRET, IBLNKS, IBLNK,KDEC,KCOMMA,KCENT,LOWER, ITERM, IQNO,NOQ, 
18530+ IMAXAC, IMAXQC, I STRSW, ISTART,NOQUES,LI ST, LAST, IGETSW, I SAVEC 20 ) , 
18540+ KEQUAL, NTAPE, KOLON , 1 CRSUM C 10, 10),NUMANS( 10) , IANALY, ICOPY, 
18550+ I COUNT, I CROSS, I TAB, I ANSWC 1 0 ) , I 0,XC 10),X2C 10),XCTC 10),IBEGA, 
18560+ N0,XMEAN< 10),XSDC 10),XMAXC 10),XMINC 10),N0DECSc 10 ) , ID1 c I 2, 6 ) , 
18570+ KZERO, KNINE, IMONTHc 22), IHEADC 3, 160), 

18580+ IOOC 10),KMASKC 10), JMASKC 10) 

18590 NWD=JWD 

18600 IF < JWD - 7) 10,10,20 

18610 10 IF ctJWD .EQ. 1) .AND. C I DATAOC 1 ) .EQ. IBLNKS)) GO TO 15 
18620 PRINT 50, C I DATAOC I ), 1=1 , JWD) 

18630 RETURN 
18640 15 PRINT, ** 

18650 RETURN 

18660 20 PRINT 50, c I DATAOC I ), 1=1,7) 

18670 JWD = JWD - 7 

18680 K = 8 

18690 30 J <= K + 4 

18700 PRINT 60, C I DATAOC I ) , I =K, J) 

18710 K = J+l 

18720 JWD » JWD- 5 

18730 IF CJWD) 40,40,30 

18740 40 JWD=NWD 

18750 RETURN 

18760 50 FORMAT C8A10) 
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18770 60 FORMAT (22X,5A10) 

18780 END 

18790 SUBROUTINE WRITREC 

18800 COMMON IQNDEX, IANDEX, IDC8,4), IDATAN<420), 

18810+ I DATAO( 300 ) , I SHFTL c 10>,ISHFTR( 10),KALLt7), IAt 18. 7 ) , IQUt 6, 1 0 ) , 
18820+ INEGC 10). I PRIME! 10),IHNDEXt 10. 10),IAN0SZt 10),ILHEAD( 10). 

18830+ IDATARt 10.2. 10),IDTSIZ( 10. 10), lELEMt 10. 10 ),XDATARt 2.10). 

18840+ ICONNC 10),XSAVEt 10),IMAXQ, I FWAAt 120>,LCGR 120), IDATt 6), 

18850+ IKDC 6. 2. 1 0 ) . INDI VQ t 1 0 ) , I OUTMX, I COMP, INMAX, IMAXA, I CHAR, I CH, 
18860+ IWD, IWDSIZ, JCHAR. JVD.KNO, I RET, I OUT, I SHFL1 ,KA,KB,KC,KD,KE,KF, 
18870+ KG.KH.KI.KJ.KK, KL.KM.KN.KO.KP.KQ.KR, KS,KT,KU,KV,KW,KX,KY,KZ, 
18880+ KCOLON, KHYPHN, KLP, KRP, KSTAR, KTAB, KDOLLR, KDELTA, KAPOST, K5ACKS, 
18890+ KRET, I BLNKS, I BLNK, KDEC, K COMMA, KCENT, LOWER, I TERM, I QNO, NOQ, 
18900+ IMAXAC, IMAXQC, I STRSW, I START, MOQUES, LI ST, LAST, I GETSW, I SAVE! 20 ) , 
18910+ KEQUAL, NTAPE, KOLON , ICRSUMt 10, 10), NUMAN S t 1 0 ) , I ANALY, I COPY, 
18920+ I COUNT, I CROSS, I TAB, 1 ANSWt 10), IO.Xc 10>,X2t 10),XCTt 10;, IBEGA, 
18930+ NO,XMEAN( 10),XSDt 10),XMAXl 10 ) ,XMINt 10), MODECSt 10 ) , I DU 1 2, 6) , 
18940+ KZERO.KNINE, IMONTHt 22) , IHEADt 3, 160), 

18950+ IOOt 10 ), KMASKt 10), JMASKt 10) 

18960 WRITE <.15,100) IQNDEX, IANDEX 
18970 DO 10 J = 1,4 

18980 10 WRITE <.15,110) <. IDt I, J), 1 = 1,7) 

18990 DO 20 M = 1, IQNDEX 

19000 20 WRITE <.15,110) <. IHEADt L, M ) , L= 1 , 3 ) 

19010 IF tIQNDEX.LE.65) GO TO 30 
19020 WRITE (15,120) ( LCQv K) , K= 1 , 65 ) 

19030 WRITE t 15, 120) t LCQt K) ,K= 66, I QNDEX ) 

19040 GO TO 40 

19050 30 WRITE (15,120) (LCQvK) , H= l , IQNDEX ) 

19060 40 MPT = 22 

19070 M = 1 

19080 50 N = M + 21 

19090 IF (IQNDEX - MPT) 70,70,60 

19100 60 WRITE (15,130) ( I FWAAC K) , K=M, N ) 

19110 M = N + 1 
19120 MPT = MPT + 22 
19130 GO TO 50 

19140 70 WRITE (15,130) C I FWAAC K) , K=M, I QNDEX ) 

19150C COMPUTE HOW MANY LINES IT TAKES TO WRITE DATA 
19160 J = 1 

19170 IZAN = CIANDEX/6) +1 
19180 IPAM = (IZAN-1) * 6 

19190 IF C IPAN.EQ. 1ANDEX) IZAN = IZAN - 1 
19200 DO 80 M = l.IZAN 
19210 K = J + 5 

19220 WRITE (15,110) C I DATAN C I ) , I = J, K) 

19230 80 J = J + 6 
19240 RETURN 

19250 100 FORMAT (IX, 2X5) 

19260 110 FORMAT (1X,7A10) 

19270 120 FORMAT (IX, 6511) 

19280 130 FORMAT (IX, 221 3) 
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19290 END 



** ’•UPDATE" — ALTERS DATA RECORDS AND POINTERS 
08/05/71. 11.31.33. 


00100C THIS PROGRAM WAS RE-DESIGNED AND DEVELOPED BY PAUL SIMMONS. 
OOUOC UNITED COMPUTING SYSTEMS. INC.. AND RONALD SCHWARZ. GODDARD 
00120C SPACE FLIGHT CENTER. JULY. 1971. 

00130C 

00140 PROGRAM UPDATE ( INPUT. OUTPUT. TAPE4. TAPE5 ) 

00150 COMMON IQC 3. 7) , I SEVNC 10 ) .KHEADC 3 ) .MHEADC 3) . KDATAC 500 ) .MDATAC 500 ) . 
00 1 60+ I TYPEC 500 ) . IAC 7. 5 ) . I DC 7. 4 ) . LHEADC 3. 1 60 > , LCQC 1 60 ) . I PNTC 1 60 ) . 
00170+ JANSC 1000). JALL.IBLNK. JCHANGE. JDELETE. JADD. JACTI ON.KAND.KOLON. 

00 1 80+ JCHNGHD. KBLNK. NRTAPE. NW TAPE. LANS. JSHFT. JCHAR. I CHAR. NANS. I RET. 
00190+ IPUT.KHCT.KDCT.MHCT.MDCT.MCOUNT.KK.KJ. IQNDEX. IANDEX.MTCH. JJ. 
00200+ KTERM. I DA TEC 18). JMASKC 10). KNEWC 20 ) 

00210 COMMON I END. MACH 
00220 DIMENSION KDATC22) 

00230 CALL CLOCKCIX) 

00240 CALL DATERCIS) 

00250 PRINT 8886. IS. IX 

00260 888 6 FORMATC /^PROGRAM: UPDATE*. 4X. * DATE 5 *.A9. 4X. *TIME ! *. A9. ///> 
00270 PRINT. *D0 YOU WANT TO MAKE MORE THAN ONE CHANGE*. 

00280 READ 2. I CYCLE 
00290 2 FORMAT CA1) 

00300 CALL INIT 

00310 3378 PRINT. *ENTER THE NAME OF THE FILE TO BE UPDATE*. 

00320 3379 READ 3.MDAT 
00330 3 FORMAT CA7 ) 

00340 CALL PFURC 3HRET. NRTAPE. MDAT.O. I STJ) 

00350 IF C I STJ .EQ. 5) GO TO 9214 
00360 NEW = 0 
00370 JSKIP=0 

00380C SET UP QUESTIONS TO BE ASKED 

00390 CALL READREC 

00400 REWIND NRTAPE 

00410 DO 5 J= 1.4 

00420 DO 5 1=2.3 

00430 K = 1-1 

00440 5 IQCI.J) = LHEADCK. J) 

00450 6 MTCHH = 0 
00460 DO 7 1=1.3 
00470 KHEADC I )=IBLNK 
00480 7 MHEADC I ) = I BLNK 
00490 DO 8 1=1.500 
00500 KDATAC I ) = I BLNK 
00510 8 MDATAC I ) = I BLNK 
00520 DO 9 1=1.20 
00530 9 KNEW C I ) = I BLNK 
00540 11 DO 12 1=1.5 
00550 DO 12 K=1 .7 
00560 12 IACK. I) = I BLNK 
00570 PRINT./ 

00580 DO 20 1=1.3 

00590 PRINT 10. CIQCJ. I).J=2.3) 

00600 10 FORMAT C2A10.7X*) 

00610 KTERM = 1 
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00620 CALL TYPEN 

00630C PUT ANSWER IN 1A ARHAY 

00640 IF C I TYPE < 1 ) .EQ. 4HD0NE) ICYCLE » 1H 

00650 IF C ITYPEC 1 > .EQ. 4HD0NE) GO TO 90 

00660 IF C ITYPEC 1) .EQ. 7HRESTART) GO TO 11 

00670 IF C ITYPEC 1) .EQ. 8HNEW FILE) NEW » 1 

00680 IF CNEW .EQ. 1) ICYCLE * 1H 

00690 IF CNEW .EQ. 1) GO TO 90 

00700 IF CNANS .EQ. 0) GO TO 20 

00710 DO 15 J=1,NANS 

00720 K = J+l 

00730 15 IACK, I ) » ITYPECJ) 

00740 20 CONTINUE 

00750C INPUT AND CONVERT DATE 

00760 16 PRINT 10, C IQC J,4), J=2, 3) 

00770 READ 22, CKDATC I ) , 1= 1 , 22) 

00780 22 FORMAT C22R1) 

00790 IF CKDATC1) .EQ. 22B .AND. KDATC2) .EQ. 05B) GO TO 11 

00800 IF CKDATC1) .EQ. 47B) GO TO 30 

00810 NDEX el 

00820 DO 24 1=1,22 

00830 I CHAR = KDATCI) 

00840 IF Cl CHAR - 45)23,24,23 
00850 23 I DATEC NDEX ) = ICHAR . 

00860 NDEX = NDEX ♦ l 
00870 24 CONTINUE 

00880 IF CKDATC1) .EQ. 01B .AND. KDATC2) .EQ. 14B) GO TO 25 

00890 I PUT =1 

00900 CALL DATEIN 

00910 GO TO C 26, 26, 26, 30) I RET 

00920 26 PRINT, *BAD DATE* 

00930 GO TO 16 

00940 25 I AC 2,4) = JALL 

00.950C ACTION 

00960 30 PRINT 10, C IQC J, 5), J=2, 3) 

00970 KTERM = l 

00980 CALL TYPEN 

00990 IF CNANS .EQ. 0) GO TO 35 

01000 IF CNANS .NE. 1) GO TO 70 

01010 IF C ITYPEC 1 ) .EQ. 7HRESTABT) GO TO 11 

01020 IF C ITYPEC 1) .EQ. JCHANGE) JACTION « JCHANGE 

01030 IF CITYPEC1) .EQ. JDELETE) JACTION = JDELETE 

01040 IF C ITYPEC D.EQ.JADD). JACTION = JADD 

01050 IF C JACTION .NE. JADD) GO TO 35 

01060 PRINT 10, CIQC J,7),J«=2,3) 

01070 GO TO 36 
01080C WHAT 

01090 35 PRINT 10, C I QC J, 6), J=2, 3) 

01100 36 KTERM =0 
OHIO CALL TYPEN 

01120 IF C ITYPEC 1) .EQ. 7HRESTART) GO TO 11 
01130 IF C ITYPEC l ) .NE. 4HALL* ) GO TO 40 
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01140 KDATAC1) * JALL 

01150 IF < JACTI ON .EQ. JDELETE) GO TO 40 
01160 PRINT, * CANNOT CHANGE OR ADD ALL* 

01170 GO TO 35 

01180 40 I PUT «= 1 

01190 CALL BUILD 

01200 GO TO <55,299,35) IRET 

01210 55 IF < JACTI ON . NE . JADD > GO TO 56 

01220 PRINT 10, <IQ< J,6),J=2,3) 

01230 GO TO 61 

01240 56 IF C JACTI ON. EQ. JDELETE) GO TO 90 
01250C CHANGE 'TO' SOMETHING 
01260 60 PRINT 10, < IQ< J,7), J=2, 3) 

01270 61 KTERM =0 
01280 CALL TYPEN 

01290 IF ( ITYPE< 1 ) .EQ. 7HRESTART) GO TO 11 

01300 I PUT = 4 

01310 CALL BUILD 

01320 GO TO <90,299,60) IRET 

01330C USER WANTS TO CHANGE A HEADING... MUST INSERT A ROUTINE HERE TO 
01340C DECIDE WHETHER OR NOT HE IS AUTHORIZED TO CHANGE HEADINGS 
01350 70 JACTI ON = JCHNGHD 
01360 GO TO 35 

01370C EITHER CHANGING A HEADING OR THERE IS NO HEADING AND MUST SHIFT 
01380C HEADING TO DATA 

01390 75 IF < JACTI ON .EQ. JCHNGHD) GO TO 90 

01400 DO 80 1*1,3 

01410 80 MDATA< I ) = MHEAD< I ) 

01420 MDCT * MHCT 

01430C READ RECORD AND LOOK FOR MATCH 

01440 90 IF < JSKIP .EQ. 1) GO TO 92 

01450 CALL READREC 

01460 IF < I END .EQ. 2) GO TO 95 

01470 IF < IRET .EQ. 1) GO TO 105 

01480 92 JSKIP=0 

01490 GO TO 105 

01500 95 IF <MATCHXS .EQ. 1) PRINT 76 

01510 76 F0RMAT</4H****,* NO MATCH FOR ID INFORMATION.*) 

01520 IF < MATCHH .EQ. 1) PRINT 77 

01530 77 FORMAT < /4H****» * NO MATCH FOUND FOR HEADER INFORMATION.*) 
01540 ENDFILE NWTAPE 

01550 REWIND NRTAPE 
01560 REWIND NWTAPE 

01570 CALL PFUR< 3HREP, NWTAPE, MDAT, 0, I STA) 

01580 47 IF < I STA .NE. 0) GO TO 49 

01590 CALL PFUR< 3HRET, NRTAPE, MDAT, 0, I STB) 

01600 I END = 0 
01610 MATCHX * 0 
01620 MATCHXS =0 
01630 MATCHH * 0 

01640 IF < I CYCLE .EQ. 1HY) GO TO 6 

01650 IF <NEW .EQ. 1) GO TO 3378 
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01660 STOP 

01670 49 GO TO 47 
01680 STOP 

01690 105 MATCHX * 0 

01700 CALL IDMATCH 

01710 IF < I RET .EQ. 2) MATCHX = 1 

01720 IF {MATCHXS .EQ. 2) GO TO 841 

01730 MATCHXS = MATCHX 

01740 IF (I RET. EQ. 1> MATCHXS = 2 

01750 841 CONTINUE 

01760 GO TO (115# 110) IRET 

01770C ID DOESN'T MATCH. . .WRITE RECORD AND GO ON 

01780 110 IF < I CYCLE .EQ. 1HY .AND. MTCHH .EQ. 1) GO TO 112 

01790 CALL WRITREC 

01800 GO TO 90 

01810 112 JSKIP=1 

01820 GO TO 6 

01830C ID MATCHES... WHAT NOW? 

01840 115 IF (JACTION .NE. JDELETE) GO TO 125 
01850 IF (KHEAD(l) .NE. JALL) 60 TO 1150 
01860 PRINT 1 1 67 # ( ID( 2# I ) # 1=1# 3) 

01870 IF (I CYCLE .EQ. 1HY) GO TO 6 
01880 GO TO 90 

01890C FIND THE HEADING TO BE ELIMINATED AND BLANK IT OUT 
01900 1150 MATCHH = 0 
01910 CALL MATCH 

01920 IF < IRET .EQ. 2) MATCHH = 1 

01930 GO TO (116# 110)# IRET 

01940 116 LHEADC 1 # MTCH ) = LHEADC 2#MTCH) =LHEAD( 3#MTCH) = IBLNK 
01950 LCQ(MTCH) = IBLNK 
01960C SHIFT THE ANSWER ARRAY 
01970 PRINT 1167# < ID<2#I )# 1=1# 3) 

01980 1 1 67 FORMAT (*MATCH ON *3(A10#1X)) 

01990 MTCHH= 1 
02000 117 J = MTCH+1 
02010 K = IPNT(MTCH) 

02020 IF ( J .GT. IQNDEX) GO TO 1172 
02030 1171 M = IPNT(J) 

02040 IF (M .NE. 0) GO TO 118 

02050 J = J+l 

02060 GO TO 1171 

02070 1172 IQNDEX = IQNDEX - 1 

02080 IANDEX = IPNT(MTCH) - 1 

02090 K = IANDEX +1 

02100 M = K + 5 

02110 DO 1174 I =K#M 

02120 1174 JANS<I) = IBLNK 

02130 GO TO 110 

02140 118 MAX = 1000 - ( IPNT( J)-IPNT(K) ) 

02150 IPT = IPNT(J) - IPNT(MTCH) 

02160 DO 119 I =K#MAX 
02170 JANSCI) = JANSCM) 
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02180 119 M = M+l 

02190C SHIFT IPNT,LCQ, LHEAD ARRAYS 

02200 DO 123 K=MTCH, 159 

02210 J = K+l 

02220 IPNT(K) = IPNT(J) 

02230 IF (IPNT<K) .NE. 0) IPNT(K)=IPMT(K)-IPT 
02240 LCQ(K) = LCQ(J) 

02250 DO 121 M=1 , 3 

02260 121 LHEAD(M,K> = LHEAD(M, J> 

02270 123 CONTINUE 
02280 IQNDEX = IQNDEX - 1 
02290 IANDEX = IANDEX - IPT 
02300 GO TO 110 

02310 124 PRINT* * SORRY, YOU CAN * T DELETE THAT* 
02320. STOP 

02330 125 IF (JACTION .NE. JADD) GO TO 160 
02340C ADD DATA TO AN ALREADY EXISTING ANSWER 
02350 MATCHH = 0 

02360 CALL MATCH 

02370 IF (IRET .EQ. 2) MATCHH = 1 

02380 GO TO (127,110) IRET 

02390 127 K = MTCH + 1 

02400 IF (MTCH .LE. 4) GO TO 159 

02410 PRINT 1167, (I D( 2, I), 1=1, 3) 

02420 MTCHH= 1 

02430 IF (K .GT. IQNDEX) GO TO 131 

02440 128 IF (IPNT(K) .NE. 0) GO TO 129 

02450 K = K+l 

02460 GO TO 128 

02470 131 DO 132 1=1,500 

02480 IF (JANS(I) .EQ. IBLNK) GO TO 133 

02490 132 CONTINUE 

02500 133 KK = I- 1 

02510 GO TO 134 

02520 129 JDIFF = IPNT(K) - IPNT(MTCH) 

02530 KK = IPNT(K) -1 

02540C COUNT CHARACTERS IN ALREADY EXISTING ANSWER 

02550 134 CALL COUNT 

02560 KBOTH = MDCT + KJ 

02570 KSTRCH = KB0TH/10 + l 

02580 LSTRCH = (KSTRCH - 1)*10 

02590 IF (LSTRCH .EQ. KBOTH) KSTRCH = KSTRCH - 1 

02600 LSHFT = KSTRCH - 1 

02610 IF (K .GT. IQNDEX) GO TO 153 

02620 IF (LSHFT) 299, 155, 135 

02630C FIND BLANK IN ANSWER ARRAY 

02640 135 DO 140 1=1,500 

02650 IF (JANS(I) .EQ. IBLNK) GO TO 145 

02660 140 CONTINUE 

02 670 1 45 K = ( I - 1 ) + LSHFT 

02680 I = K - LSHFT 

02690 150 JANS(K) = JANS(I) 
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02700 I « 1-1 
02710 K = K-l 

02720 IF Cl .GT. IPNTCMTCH)) GO TO 150 
02730 JANSCI+1) =» IBLNK 

027 40C ANSWERS HAVE BEEN SHIFTED UP... NOW ENTER DATA TO BE ADDED 
02750 155 CONTINUE , 

027 60C ADJUST IPNT ARRAY 

02770 K = MTCH+l 

02780 DO 152 I=K*160 

02790 IF CIPNTCI) .EQ. 0) GO TO 1 52 

02800 IPNTCI) = IPNTCI) + LSHFT 

02810 152 CONTINUE 

028 20C 

02830 153 IANDEX = IANDEX + LSHFT 

02840 I PUT =5 

02850 MCOUNT a 0 

02860 NW * 1 

02870 NC = 0 

02880 IF CKJ .LT. 10) GO TO 156 
02890 KK = KK+ 1 
02900 KJ ** 0 

02910 156 KSHFT = CNC*6)-54 

02920 ICHAR » ISHIFTCMDATACNW) *KSHFT> .AND. HAND 

02930 CALL STRCH 

02940 KJ = KJ+1 

02950 NC a NC+1 

02960 MCOUNT «* MCOUNT+l 

02970 IF C MCOUNT .GT. MDCT) GO TO 110 

02980 IF CKJ .GT. 9) GO TO 158 

02990 157 IF CNC .LE. 9) GO TO 156 

03000 NC a O 

03010 NW a NW+1 

03020 GO TO 156 

03030 158 KJ = 0 

03040 KK = KK+1 

03050 JANSCKK) = IBLNK 

03060 GO TO 157 

03070 159 PRINT* *YOU CAN ONLY CHANGE DATA IN THE FIRST 4 HEADINGS* 
03080 STOP 

03090 160 IF C JACTION .NE. JCHANGE) GO TO 220 

03100C CHANGE DATA 

03110 MATCHX a 0 

03120 MATCHH =0 

03130 • CALL MATCH 

03140 IF CIRET .EQ. 2) MATCHH = 1 

03150 GO TO Cl 65*110)* I RET 
03160 165 K = MTCH +1 
03170 PRINT 1167* C IDC 2* I ) » 1 = 1 * 3 > 

03180 MTCHH=1 

03190 IF CK .GT. IQNDEX) GO TO 167 
03200 IF CK .LE. 4) GO TO 218 
03210 IF CK .EQ. 5) GO TO 240 
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03220 166 JDIFF = IPNT(K) - IPNT(MTCH) 

03230 IF < JDIFF .GT. 0) GO TO 167 

03240 K « K + 1 

03250 GO TO 166 

03260 167 KSTRCH * MDCT/10 + 1 

03270 LSTRCH = C KSTRCH - 1)*10 

03280 IF (LSTRCH .EQ« MDCT) KSTRCH = KSTRCH - 1 

03290 IF CK .GT. IQNDEX) GO TO 210 

03300 IF (K .LE. 5) GO TO 216 

03310 IF (JDIFF - KSTRCH) 170.210.195 

03320C MUST SHIFT DATA UP TO ACCOMODATE BIGGER DATA FIELD 

03330 170 DO 175 1=1.1000 

03340 IF (JANS(I) .EQ. IBLNK) GO TO 180 

03350 175 CONTINUE 

03360 180 L = ((KSTRCH - JDIFF) - 1) + I 

03370 M * I - 1 

03380 185 JANS(L) = JANS(M) 

03390 L = L - 1 
03400 M = M -1 

03410 IF (M .GT. IPNT(MTCH) ) GO TO 185 

03420C DATA HAS BEEN SHIFTED UP... NOW MAKE CHANGE 

03430C CHANGE POINTERS 

03440 N = KSTRCH - JDIFF 

03450 M a MTCH + 1 

03460 DO 192 I=M. 160 

03470 IF (IPNT(I) .NE. 0) IPNT(I) = IPNT(I) + N 

03480 192 CONTINUE 

03490 IANDEX = IANDEX + N 

03500 187 N = IPNT(MTCH) 

03510 DO 190 1=1. KSTRCH 
03520 JANS(N) = MDATAC I ) 

03530 190 N = N + 1 
03540 GO TO 110 
03550C SHIFT DATA DOWN 
03560 195 M = IPNT(MTCH) 

03570 N = M + ( JDI FF-KSTRCH) 

03580 DO 200 I=N. 1000 
03590 JANS(M) = JANS(I) 

03600 200 M = M+l 

03610 DO 205 I=K. 160 

03620 IF (IPNT(I) .EQ. 0) GO TO 205 

03630 IPNT(I) = IPNT(I) - (JDIFF - KSTRCH) 

03640 205 CONTINUE 

03650 IANDEX = IANDEX - (JDIFF - KSTRCH) 

03660 GO TO 187 

03670C NO SHIFTING REQUIRED 

03680 210 M = IPNT(MTCH) 

03690 DO 215 1=1. KSTRCH 
03700 JANS(M) = MDATA( I ) 

03710 215 M = M+l 
03720 DO 216 1=1.1000 

03730 IF (JANS(I) .EQ. IBLNK) GO TO 217 
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03740 216 CONTINUE 
03750 217 IANDEX =1-1 
03760 GO TO 110 
03770 218 DO 219 1 = 1.6 
03780 J = 1 + 1 

03790 IF (IQUT .EQ. 3) GO TO 219 
03800 MDATA< I ) = I SHI FT(MDATA( I ). 1 2) 

03810 MDATA(I) = MDATA( I ) .AND. ISEVNC8) 

03820 LTCHAR = MDATA(J) .AND. ISEVN(2) 

03830 LTCHAR = I SHIFT! LTCHAR. -48) .AND. 7777B 
03840 MDATA( I ) = MDATAC I > . OR. LTCHAR 
03850 219 ID(J.MTCH) = MDATA( I ) 

03860 IQUT =3 ' . 

03870 GO TO 1 10 

03880 220 IF (JACTION .NE. JCHNGHD) GO TO 299 

03890 CALL MATCH 

03900 GO TO (225.110) IRET 

03910 225 DO 230 1=1.3 

03920 230 LHEAD(I.MTCH) = MHEAD(I) 

03930 PRINT 1167. ( ID< 2. I ). 1=1. 3) 

03940 MTCHH=1 
03950 GO TO 110 

03960 299 PRINT. *PROGRAMMING ERROR* 

03970 STOP 

03980 240 IF (ISTP .EQ. 1) GO TO 260 

03990 IS = 1 

04000 DO 250 1=1.2 

04010 DO 245 J=1.10 

04020 KSHFT = (J*6)-60 

04030 IDATE(IS) = I SH I FT C MDATA( I ) , KSHFT ) .AND. HAND 

04040 I F ( I DATE< I S ) .NE. 55B. AND. I DATEC I S ) . NE . 63B. AND. I DATE( I S ) . NE. 

04050+ 62B) IS = IS+1 
04060 245 CONTINUE 
04070 250 CONTINUE 
04080 ISTP = 1 
04090 I PUT = 3 
04100 CALL DATE IN 

04110 GO TO (255.255.255.260) IRET 

04120 255 PRINT. *Y0U GAVE ME A SCREWY DATE* 

04130 STOP 

04140 9214 PRINT 9215.MDAT 

04150 9215 FORMAT*/*"*. A7.*"*.* NOT IN PERMANENT STORAGE.*) 

04160 PRINT. *RE-ENTER VALID FILE NAME*. 

04170 GO TO 3379 
04180 260 DO 265 1=1.3 
04190 J=I+1 

04200 265 ID( J.4) = MDATA( I ) 

04210 GO TO 110 
04220 END 

04230 SUBROUTINE IDMATCH 

04240 COMMON I Q ( 3. 7 ) . I SEVN( 10). KHEAD( 3 ) . MHEAD( 3 ) . KDATA( 500 ) . MDATA! 500 ) . 
04250+ ITYPE( 500 ). I A( 7, 5) . ID(7» 4) .LHEAD( 3. 1 60 ) .LCQC l 60) . IPNT( l 60 ) . 
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04260+ JANS< 1 000 > * JALL* I BLNK* JCHANGE* JDELETE* JADD, JACT ION* HAND. KOLON* 
0427 0 + JCHNGHD* KBLNK* N RT APE* NWTAPE* LANS* JSHFT* JCHAR* 1 CHAR* NANS * I RET * 
04280+ IPUT*KHCT*KDCT*MHCT*MDCT*MCOUNT*KK*KJ* I QNDEX* I ANDEX*MTCH* JJ* 
04290+ KTERM* IDATEC 18)» JMASKC 10 > * KNEWC 20 ) 

04300 COMMON I END* MACH 
04310 DO 10 J=l*3 

04320 IF CIAC2,J> .EQ. JALL) GO TO 10 
04330 DO 5 1=2*4 

04340 IF < IA< I* J) .NE. IDCI*J>> GO TO 50 

04350 5 CONTINUE 

04360 10 CONTINUE 

04370C NOW CHECK DATE RANGE 

04380 IF C IAC 2*4) .EQ. JALL) GO TO 45 

04390 IF C IDC 2*4) - I AC 2* 4) > 50* 20* 30 

04400 20 IF C IDC3*4) - IAC 3* 4) > 50* 25* 30 

04410 25 IF C I DC 4*4) - IAC 4*4) >50*30* 30 

04420 30 IF C I DC 2*4) - IAC 2* 5) ) 45* 35* 50 

04430 35 IF CIDC3*4> - I AC 3* 5) >45* 40* 50 

04440 40 IF C I DC 4* 4) - I AC 4* 5 )) 45* 45* 50 

04450 45 I RET = 1 

04460 RETURN 

04470 50 I RET =2 

04480 RETURN 

04490 END 

04500 SUBROUTINE TYPEN 

04510 COMMON I QC 3* 7 ) * I SEVNC 10 )*KH£ADC 3) * MHEADC 3) *KDATAC 500 )*MDATAC 500 ) * 
04520+ ITYPEC 500) * IAC7* 5) * I DC 7* 4) ,LHEADC 3* 1 60 ) *LCQC 1 60) , IPNTC 1 60 ) , 
04530+ JANS C 1 000 ) * JALL* I BLNK* JCHANGE* JDELETE* JADD* JACT I ON* HAND* KOLON, 
04540+ JCHNGHD*KBLNK*NRTAPE*NWTAPE*LANS* JSHFT* JCHAR* I CHAR* NANS* I RET* 
04550+ IPUT*KHCT*KDCT*MHCT*MDCT*MCOUNT*KK* KJ* I QNDEX* I ANDEX,MTCH* JJ, 
04560+ KTERM* I DATEC 1 8 ) » JMASKC 10)* KNEWC 20 ) 

04570 COMMON I END* MACH 
04580 NANS =0 
04590 K = 1 
04600 5 M=K+4 

04610 READ 10* C ITYPECN),N=K*M) 

04620 10 FORMAT C6A10) 

04630 DO 15 I=K*M 

04640 IF C ITYPEC I) .EQ. I BLNK ) GO TO 35 
04650 NANS = NANS +1 
04660 15 CONTINUE 

04670 20 CALL ETERMC ITYPECM) * JSWIT* KTERM) 

04680 IF C JSWIT .EG. 1) GO TO 30 

04690 K = M+l 

04700 PRINT 25 

04710 25 FORMAT C27X»> 

04720 GO TO 5 

04730 30 IF C ITYPECM) .EQ. I BLNK ) NANS=NANS-1 

04740 RETURN 

04750 35 M=I-1 

047 60 GO TO 20 

04770 END 
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04780 SUBROUTINE STRCH 

04790 COMMON IQ<3*7)» ISEVNC 10)*KHEADC3)*MHEADC3)*KDATAC500)*MDATA<500)* 
04800+ ITYPEC 500) * IAC7»5)»ID< 7*4) *LHEAD< 3*160 ) *LCQ< 1601* IPNT< 1 60 ) * 

048 1 0+ JANSC 1 000 > * JALL* I BLNK* JCHANGE* JDELETE* JADD* JACT 1 ON* HAND* KOLON* 
048 S0+ JCHNGHD,KBLNK,NRTAPE,NWTAPE, LANS* JSHFT* JCHAR* I CHAR* NANS* IRET* 
04830+ IPUT*KHCT*KDCT*MHCT*MDCT*MCOUNT*KK*KJ» IQNDEX* IANDEX*MTCH* JJ* 
04840+ KTERM* I DATEC 18)* JMASKC 10)* KNEWC 20 ) 

04850 COMMON I ©ID* MACH 
04860 JSHFT = 54-<KJ*6) 

04870 I SUBS e < JSHFT/6) + 1 

04880 GO TO <5*10*15*20*25*30) IPUT 

04890 5 KHEAD(KK) = CKHEADCKK) .AND. JMASKC I SUBS) ). OR. ISHIFTC ICHAR* JSHFT) 
04900 RETURN 

049 10 10 KDATAC KK ) = CKDATAC KK ) . AND. JMASKC I SUBS >). OR. I SHI FTC TCHAR* JSHFT ) 
04920 RETURN . 

04930 15 MHEADC KK)=CMHEADCKK). AND. JMASKC I SUBS) ) . OR. ISHIFTC ICHAR* JSHFT) 
04940 RETURN 

04950 20 MDATACKK)®CMDATACKK) .AND. JMASKC I SUBS) ) • OR. ISHIFTC ICHAR* JSHFT) 
04960 RETURN 

04970 25 JANSCKK) “< JANSCKK) .AND. JMASKC I SUBS) ) . OR. ISHIFTC I CHAR* JSHFT) 
04980 RETURN 

04990 30 KNEWC KK)=< KNEWC KK) .AND. JMASKC I SUBS) ) • OR. ISHIFTC ICHAR* JSHFT) 
05000 RETURN 
05010 END 

05020 SUBROUTINE COUNT 

05030 COMMON I Q < 3* 7 ) * I SEUNC 10)* KHEADC 3 ) * MHEADC 3 ) * KDATAC 500 ) *MDATA< 500 ) * 
05040+ ITYPEC 500)* I AC 7*5)* IDC7*4)*LHEADC 3* 1 60>*LCQ< 160)* IPNTC 160)* 
05050+ JANSC 1000 ) * JALL* I BLNK* J CHANGE* JDELETE* JADD* JACTI 0N,KAND*K0L0N, 
05060+ JCHNGHD*KBLNK*NRTAPE*NWTAPE*LANS* JSHFT* JCHAR* I CHAR* NANS* IRET* 
05070+ IPUT*KHCT*KDCT*MHCT*MDCT*MCOUNT»KK*KJ* IQNDEX* IANDEX*MTCH* JJ* 
05080+ KTERM* I DATE C 1 8 ) * JMASKC 10)* KNEWC 20 > 

05090 COMMON I END* MACH 

05100 KJ - 10 

05110 JSHFT = 6 

05120 DO 5 I»l*10 

05130 2 JSHFT = JSHFT - 6 

05140 ICHAR ® ISHIFTC JANSCKK)* JSHFT) .AND. KAND 

05150 IF < ICHAR .NE. 55B) RETURN 

05160 5 KJ « KJ - 1 

05170 GO TO 2 

05180 END 

05190 SUBROUTINE READREC 

05200 COMMON I QC 3* 7 ) * I SEVNC 1 0 ) * KHEADC 3 ) * MHEADC 3 ) * KDATAC 500 ) * MDATAC 500 ) * 
05210+ ITYPEC 500). IAC7*5)*IDC7*4)*LHEADC 3* 1 60) »LCQC l 60)* IPNTC 1 60 ) * 
05220+ JANSC 1000)* JALL*IBLNK* JCHANGE* JDELETE* JADD* JACTI 0N*KAND*K0L0N* 
05230+ JCHNGHD»KBLNK*NRTAPE*NWTAPE* LANS* JSHFT* JCHAR* I CHAR*NANS* IRET* 
05240+ IPUT*KHCT*KDCT*MHCT*MDCT*MCOUNT*KK*KJ* IQNDEX* IANDEX*MTCH* JJ* 
05250+ KTERM*IDATE< 18)* JMASKC 10)*KNEWC20) 

05260 CC»1M0N I END* MACH 

05270 READ <NRTAPE*100) IQNDEX* IANDEX 

05280 IF CEOF*NRTAPE) 140* 5 

05290 5 DO 10 J=l*4 
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05300 10 READ (NRTAPE,110) ( ID( I, J), I = 1,7) 

05310 IDO, 4) = IDO. 4) .AND. 77B 
05320 DO 20 M=l, IQNDEX 

05330 20 READ (NRTAPE, 110) (LHEAD(L,M),L=1,3) 

05340 IF ( IQNDEX .LE. 65) GO TO 30 
05350 READ (NRTAPE, 120) (LCQ(K) ,K= 1, 65) . 

05360 READ (NRTAPE, 120) (LCQ(K) ,K=66, I QNDEX) 

05370 GO TO 40 

05380 30 READ (NRTAPE, 120) (LCQ(K),K=1, IQNDEX) 

05390 40 MPT = 22 

05400 M = l 

05410 50 N * M+21 

05420 IF (IQNDEX - MPT)70,70,60 

05430 60 READ (NRTAPE, 130) ( IPNT(K),K=M,N) 

05440 M » N+l 
05450 MPT = MPT+22 
05460 GO TO 50 

05470 70 READ (NRTAPE, 130) < IPNT(K),K=M,IQNDEX) 

05480C COMPUTE HOW MANY LINES IT TAKES TO READ DATA 
05490 J * 1 

05500 IZAN = (IANDEX/6) + 1 
05510 I PAN *■ (IZAN - 1)*6 

05520 IF (IPAN .EQ. IANDEX) IZAN = IZAN - 1 
0S530 DO 90 M=l, IZAN 
05540 K = J+5 

05550 READ (NRTAPE, 110) ( JANS( I ) , I- J,K) 

05560 90 J * J+6 
05570 I RET = 1 
05580 RETURN 

05590 100 FORMAT (IX, 21 5) 

05600 110 FORMAT (1X.7A10) 

05610 120 FORMAT (IX, 6511) 

05620 130 FORMAT, ( IX, 221 3) 

05630 140 I END =2 
05640 RETURN 
05650 END 

05660 SUBROUTINE IN IT 

05670 COMMON IQ( 3,7 ), I SEVN( 1 0),KHEAD( 3),MHEAD( 3),KDATA( 500),MDATA(500 ), 
05680+ I TYPE (.500), I A(7> 5), ID(7, 4),LHEAD( 3, 1 60) ,LCQ( 1 60) , IPNT( 1 60 ), 
05690+ JANS( 1000 ) , JALL, I BLNK, JCHANGE, JDELETE, JADD, JACTI ON, KAND,K0L0N, 
05700+ JCHNGHD, KBLNK, NRTAPE, NW TAPE, LANS,. JSH FT, JCHAR, I CHAR, NANS, I RET, 
05710+ IPUT,KHCT»KDCT,MHCT,MDCT,MCOUNT,KK,KJ, IQNDEX, IANDEX.MTCH, <JJ, 
05720+ KTERM, I DATE( 18), JMASK( 10>,KNEW(20> 

05730 COMMON I END, MACH 
05740 IQ( 2, 5) ■ 6HACTI0N 
05750 IQ(2,6) = 4HWHAT 
05760 IQ( 2,7 ) = 2HT0 
05770 JALL = 3HALL 
05780 I BLNK = 10H 
05790 JCHANGE = 6H CHANGE 
05800 JDELETE * 6HDELETE 
05810 JADD a 3HADD 
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05820 JACTI ON = IBLNK 
05830 HAND = 77B 
05840 KOLON = 63B 
05850 JCHNGHD = 1 OHCHANGEHEAD 
05860 KBLNK * 55B 

05870 ISEVNC 1 > =077000000000000000000 
05880 ISEVNC 2) = 077770000000000000000 
05890 ISEVNC 3) = 077777700000000000000 
05900 ISEVNC 4) = 077777777000000000000 
05910 ISEVNC5) = 077777777770000000000 
05920 ISEVNC 6) = 077777777777700000000 
05930 ISEVNC 7 ) = 077777777777777000000 
05940 ISEVNC8) =077777777777777770000 
05950 ISEVNC 9) = 077777777777777777700 
05960 ISEVNC 10) = 077777777777777777777 
05970 JMASKC1) = 077777777777777777700 
05980 JMASKC 21 = 077777777777777770077 
05990 JMASKC 3) = 077777777777777007777 
06000 JMASKC4) » 077777777777700777777 
06010 JMASKC 5) = 077777777770077777777 
06020 JMASKC 6) = 077777777007777777777 
06030 JMASKC 7) = 077777700777777777777 
06040 JMASKC 8) = 077770077777777777777 
06050 JMASKC 9) = 077007777777777777777 
06060 JMASKC 10)» 000777777777777777777 
06070 NRTAPE =4 * 

06080 NWTAPE =5 
06090 DO 30 I = 1,1000 
06100 30 JANSCI) = IBLNK 
06110 DO 35 J=1 ,7 
06120 DO 35 1=1,5 
06130 35 IACJ.I) = IBLNK 
06140 RETURN 
06150 END 

06160 SUBROUTINE MATCH 

06170 COMMON I QC 3, 7 ) , I SEVN CIO), KHEADC 3 ) ,MHEADC 3 ) ,KDATAC 500 > ,MDATAC 500 ) , 
06180+ I TYPEC500), I AC 7, 5), IDC 7, 4),LHEADC 3, 1 60),LCQC 160), IPNTC 160), 
06190+ JANSC 1000), JALL, IBLNK, JCHANGE, JDELETE, JADD, JACTION,KAND,KOLON, 
06200+ JCHNGHD, KBLNK, NRTAPE, NWTAPE, LANS, JSHFT, JCHAR, ICHAR,NANS, IRET, 
06210+ I PUT, KHCT,KDCT,MHCT,MDCT, MCOUNT, KK, KJ, I QNDEX, I ANDEX,MTCH, JJ, 
06220+ KTERM,IDATEC 18), JMASKC 10),KNEWC20) 

06230 COMMON I END, MACH 
06240 IPUT=6 

06250 J=1 • ‘ 

06260C DO HEADINGS MATCH? 

06270 5 DO 10 K=l,3 

06280 IF CLHEADCK, J)-KHEADCK) )90, 1 0, 90 
06290 10 CONTINUE 

06300C HEADING MATCHES... DOES DATA? ‘ 

06310 IF C JACTI ON. EQ. JCHNGHD) GO TO 95 
06320 IF CKDATAC1-).EQ. IBLNK) GO TO 95 
06330 IF CJ-4) 105,120,15 
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06340 15 LPOINT=IPNT< J) 

06350 K=J 
06360 20 K*K+1 

06370 IF CK.GT. IQNDEX) GO TO 30 
06380 IF CIPNTUO.EQ.O) GO TO 20 
06390 LIMIT=IPNTCK> 

06400 GO TO 35 
06410 30 LIMIT=IANDEX 
06420 35 I FI RST=0 
06430 J0UNT=0 
06440 IGET=I FIRST 
06450 40 KK=1 
06460 KJ=0 

06470 45 IF ( IGET.LE. 9) GO TO 50 

06480 IGET=0 

06490 LP0INT=LP0INT+1 

06500 IF CLPOINT.GT.LIMIT) GO TO 90 

06510 50 JSHFT=<IGET*6>-54 

06520 ICHAR=ISHIFTC JANSCLPOINT), JSHFT) .AND.77B 

06530 CALL STRCH 

06540 JO UNT=J0UNT+1 

06550 IF <JOUNT.EQ.KDCT) GO TO 65 

06560 KJ=KJ+1 

06570 IF CKJ.LE.9) GO TO 60 

06580 KJ=0 

06590 KK=KK+1 

06600 60 IGET=IGET + 1 

06610 GO TO 45 

06620C SEE IF DATA MATCHES 

06630 65 DO 75 M=l,20 

06640 IF < KNEW < M ) ■• I BLNK ) 70,95,70 

06650 70 IF <KDATA<M)-KNEWCM) ) 80,75,80 

06660 75 CONTINUE 

06670 GO TO 95 

06680C DOESN’T MATCH... TRY AGAIN 

06690 80 IFIRST=IFIRST+1 

06700 LP0INT=IPNT< J) + IFIRST/10 

06710 J0UNT=0 

06720 DO 85 M=l,20 

06730 85 KNEW ( M ) = I BLNK 

06740 GO TO 40 

06750 90 J=J+1 

067 60 IF < J- IQNDEX) 5,5,100 

06770 95 IRET=1 

06780 MTCH= J 

06790 RETURN 

06800 100 I RET=2 

06810 RETURN 

06820C SEE IF THE LEADER MATCHES 
06830 105 DO 110 K=l,6 
06840 L «s K+ 1 

06850 IF (KDATA(K)-IDCL, J) ) 115,110,115 
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06860 110 CONTINUE 
06870 111 IRET=1 
06880 MTCH = J 
06890 RETURN 
06900 115 J*J+1 
06910 GO TO 5 

06920C SEE IF DATE MATCHES 
06930 120 1=1 
06940 DO 130 K=l#2 
06950 DO 125 L*l#10 
06960 KSHFT = C6*L) - 60 

06970 IDATEC I > =1 SHI FTCKDATACK) # KSHFT) .AND. 77B 

06980 IF C IDATEC I ) .NE. 55B. AND. I DATEC I > .NE. 63B. AND. IDATEC I ) .NE, 62B) 1*1+1 

06990 125 CONTINUE 

07000 130 CONTINUE 

07010 IPUT=2 

07020 CALL DATEIN 

07030 GO TO C135#135#135#105)#IRET 

07040 135 PRINT# *YOU GAVE ME A SCREWY DATE* 

07050 STOP 
070 60 END 

07070 SUBROUTINE BUILD 

07080 COMMON I QC 3# 7 ) # I SEVNC 10)# KHEADC 3 > # MHEADC 3 > # KDATAC 500 ) # MDATAC 500 ) # 
07090+ ITYPEC 500 ># IAC7# 5)# IDC7# 4)#LHEADC 3# 1 60 >#LCQC 160)# IPNTC 1 60 ) # 
07100+ JANSC 1 000 ) # JALL# I BLNK# JCHANGE# JDELETE# JADD# JACT I ON# HAND# KOLON# 

07 1 10+ JCHNGHD#KBLNK#NRTAPE,NWTAPE#LANS# JSHFT# JCHAR# I CHAR# NANS# I RET# 
07120+ IPUT#KHCT,KDCT,MHCT#MDCT,MC0UNT,KK#KJ#IQNDEX,IANDEX,MTCH#JJ# 

07130+ KTERM# IDATEC 1 8) #JMASKC 10)#KNEWC20) 

07140 COMMON I END# MACH 

07150 LCNT=0 $ IRET=1 $ LANS=l S IRET=1 
07160 JCHAR =0 
07170 KK= 1 

07180 KJ=0 ' 

07190 10 JSHFT* C JCHAR* 6) -54 

07 200 I CHAR® I SHI FTC I TYPEC LANS ) # JSHFT > . AND. 77B 

07210 IF CICHAR.EQ.47B) GO TO 25 

07220 IF CICHAR.EQ.63B) GO TO 35 

07230 12 IF CICHAR .EQ. 51B) ICHAR = 62B 

07240 IF CICHAR .EQ. 52B) ICHAR = 63B 

07250 CALL STRCH 

07260 LCNT=LCNT+1 

07270 15 JCHAR* JCHAR+ 1 

07280 K J=K J+ 1 

07290 IF CKJ.GT.9) GO TO 30 
07300 20 IF CJCHAR.LE.9) GO TO 10 
07310 LANS=LANS+1 
07320 JCHAR* 0 

07330 IF CLANS.LE. CNANS+1 ) ) GO TO 10 
07340 22 I RET* 3 

07350 25 GO TO C 26# 27# 28# 29)# IPUT 
07360 26 KHCT=LCNT 
07370 RETURN 
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07380 27 KDCT=LCNT 
07390 RETURN 
07400 28 MHCTeLCNT 
07410 RETURN 
07420 29 MDCT=LCNT 

07430 IF < JACTION .EQ. JCHNGHD) GO TO 37 
07440 IF (JACTION .EQ. JADD) RETURN 
07450 IF (MDATA(l) .EQ. IBLNK) RETURN 
07460 K = ISHIFT(MDATA< 1 ), -54) .AND. 77B 
07470 IF (K .EQ. 62B) RETURN * 

07480 K = MDCT/10 + 2 

07490 ISAVE1=63620000000000000000B 

07500 DO 291 L=1,K 

07510 ISAVE2= MDATA(L> .AND. 7777B 

07520 MDATA(L) = ISHIFT(MDATA(L),-12> .AND. 7777777777777777B 
07530 MDATA(L) = MDATA(L) .OR. ISAVE1 
07540 291 I SAVE 1 = ISHIFT< ISAVE2,48) 

07550 LCNT = LCNT+2 
07560 RETURN 
07570 30 KJ=0 
07580 KK=KK+ 1 
07 590 GO TO 20 

07600 35 GO TO (36,50,37,37), IPUT 

07610 36 KHCT=LCNT 

07620 IPUT = IPUT+1 

07630 GO TO 38 

07640 37 MHCT=LCNT 

07650 DO 371 L=l,3 

07660 MHEAD(L) = MDATA(L) 

07670 371 MDATA(L) = IBLNK 

07680 IF (JACTION .EQ. JCHNGHD) RETURN 

07690 38 LCNT=0 

07700 KK= 1 

07710 KJ=0 

07720 39 JCHAR= JCHAR+ 1 
07730 IF (JCHAR.LE.9) GO TO 40 
07740 LANS=LANS+1 
07750 JCHAR=0 

07760 IF (LANS.GT. (NANS+1 ) ) GO TO 22 
07770 40 JSHFT=( JCHAR*6)-54 

07780 ICHAR=I SHIFT( I TYPE (LANS) , JSHFT) .AND. 77 B 
07790 IF (ICHAR-55B) 12,39,12 

07800 50 PRINT, * PROG RAMM I NG ERROR, SEE PROGRAMMER* 

07810 STOP 
07820 END 

07830 SUBROUTINE WRITREC 

07840 COMMON I Q( 3, 7 ) , I SEVN( 10 ) ,KHEAD( 3 > , MHEADC 3 ) ,KDATA( 500 ) ,MDATA( 500 ) , 
07850+ I TYPE( 500), IA(7,5),ID(7,4), LHEAD( 3,1 60 ) , LCQ( 1 60 ) , I PNT( 1 60 ) , 
07860+ JANS( 1000 ) , JALL, I BLNK, JCHANGE, JDELETE, JADD, JACTI ON,KAND,KOLON, 
07870+ JCHNGHD,KBLNK,NRTAPE,NWTAPE,LANS, JSHFT, JCHAR, ICHAR,NANS, IRET, 
07880+ IPUT,KHCT,KDCT,MHCT,MDCT,MCOUNT,KK,KJ, IQNDEX, IANDEX,MTCH, JJ, 
07890+ KTERM, IDATE( 18), JMASK( 10>,KNEW(20) 
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t 

07900 COMMON I END* MACH 

07910 WRITE <NWTAPE*100) IQNDEX* IANDEX 

07920 DO 10 J = 1*4 

07930 10 WRITE <NWTAPE*UO) { ID( I* J)* 1*1*7) 

07940 DO 20 M = 1,IQNDEX 

07950 20 WRITE CNWTAPE*110) (LHEAD(L*M)*L=1* 3) 

07960 IF (IQNDEX.LE. 65) GO TO 30 

07970 WRITE (NWTAPE*120) (LCQ(K)* K=i*65) 

0798a WRITE <NWTAPE*120) (LCQ(K)* K = 66*IQNDEX> 

07990 GO TO 40 

08000 30 WRITE <NWTAPE*120) (LCQ(K)* K = 1* IQNDEX) 

08010 40 MPT =22 

08020 M = 1 

08030 50 N = M + 21 

08040 IF (IQNDEX - MPT) 70*70*60 

08050 60 WRITE (NWTAPE*130> (IPNT(K)* K= M*N) 

08060 M = N + 1 
08070 MPT = MPT +22 
08080 GO TO 50 

08090 70 WRITE (NWTAPE* 130) (IPNT(K>* K=M* IQNDEX) 
08100C COMPUTE HOW MANY LINES IT TAKES TO WRITE DATA 
08110 J = 1 

08120 IZAN = (IANDEX/6) + 1 

08130 I PAN = (IZAN-1) * 6 

08140 IF ( I PAN. EQ. IANDEX) IZAN IZAN - 1 

08150 DO 80 M = 1,IZAN 

08160 K = J + 5 

08170 WRITE (NWTAPE* 110) CJANSCD* I = J*K) 

08180 80 J = J + 6 
08190 RETURN 

08200 100 FORMAT <1X*2I5) 

08210 110 FORMAT <1X*7A10) 

08220 120 FORMAT < IX* 6511) 

08230 130 FORMAT C IX* 221 3) 

08240 END 

v 08250 SUBROUTINE ETERM C NTERM * MSW I T* JTERM ) 

08260 MSWIT = 0 

08270 I AND = 077000000000000000000 
08280 I OR = .NOT. I AND 
, 08290 JASTK = 047000000000000000000 
08300 IBK = 055000000000000000000 
08310 IBLNK = 10H 
08320 NNEW = NTERM. AND. I AND 
08330 IF (NNEW. EQ. JASTK) GO TO 20 
08340 DO 10 K = 1*10 
08350 NTERM = ISHIFT(NTERM* 6) 

08360 NNEW = NTERM. AND* I AND 
08370 IF (NNEW. NE. JASTK) GO TO 10 
08380 NTERM = NTERM. AND. I OR 
08390 MSWIT « 1 
08400 IF ( JTERM. EQ.O) GO TO 5 
08410 NTERM = NTERM. OR. IBK 
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08420 GO TO 10 

08430 5 NTERM = NTERM • OR. JASTK 
08440 10 CONTINUE 
08450 RETURN 

08460 20 IF < JTERM.EQ. 1 > NTERM = IBLNK 
08470 MSWIT = 1 
08480 RETURN 
08490 END 

08500 SUBROUTINE DATE IN 

08510 COMMON IQC 3, 7 ) , ISEVNC 10) ,KHEADC 3), MHEADC 3 ) ,KDATAC 500 ) ,MDATAC 500) , 
08 520+ I TYPEC 500 ) , I AC 7, 5 ) , ID< 7, 4> , LHEAD< 3* 1 60) , LCQC1 60 ) , IPNTC 1 60 ), 

08 530+ JANSC 1000 ) , JALL, I BLNK, JCHANGE, JDELETE, JADD, JACTI ON, KAND,KOLON, 
08540+ JCHNGHD, KBLNK,NRT APE, NWTAPE, LANS, JSHFT, JCHAR, I CHAR, NANS, I RET, 
08550+ I PUT,KHCT, KDCT,MHCT,MDCT, MCOUNT , KK, K J, I QNDEX, I ANDEX,MTCH, JJ, 
08560+ KTERM, IDATEC 18), JMASKC 1 0 ) ,KNEWC 20 ) 

08570 DIMENSION IMONTHC 22) 

08580 DATA IM0NTH/01 20116, 00 60502, 01 50 1 22, 0012022, 01 501 3 1 i 01 2251 6, 
08590+ 0122514,0012507,0230520,0170324, 0161726,0040503,0251613/ 

08600 KZERO = 27 
08610 KNINE =36 
08620 I TERM = 39 

08630 IFILLO = 033333333333333330000 

08640 ISHFL1 = 2**6 

08650 KHYPHN =38 

08660 1=0 

08670 MM = 1 

08680 IDAY1 = KZERO 

08690 IDAY2 = KZERO 

08700 GO TO 145 

08710 110 I = I + 1 

08720 IF CIDATECD-ITERM) 135,115,135 
08730 115 IAC 2, 5) = IAC 2, 4) 

08740 I AC 3,5) = IAC3,4) 

08750 IF C I FLAG) 125,120,125 

08760 120 IAC 4, 5) = CKZER0+3)*ISHFLt + CKZER0+l J + IFILLO 

08770 GO TO 130 

08780 125 IAC 4, 5 ) = IAC4,4) 

08790 130 IRET = 4 
08800 RETURN 

08810 135 IF C IDATEC I) -KHYPHN) 190,140,190 

08820 140 MM = 2 

08830 IDAY1 = KZERO + 3 

08840 I DAY 2 = KZERO + 1 

08850 145 I FLAG = 0 

08860 150 1=1+1 

08870 I CHAR = IDATEC I) 

08880 IF CICHAR-KNINE) 155,155,175 

08890 155 IF C I CHAR- KZERO ) 175,160,160 

O890O 160 I FLAG = I FLAG + 1 

08910 GO TO Cl 65, 170), I FLAG 

08920 165 IDAY1 = KZERO 

08930 I DAY 2 = I CHAR 
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** "UPDATE" — ALTERS DATA RECORDS AND POINTERS 
08/05/71. 11.31.33. 


08940 GO TO 150 

08950 170 IDAY1 = IDAY2 

08960 IDAY2 = I CHAR 

08970 1=1+1 

08980 I CHAR = I DATE! I) 

08990 175 K * I CHAR 
09000 1=1+1 
09010 L = IDATECI) 

09020 1=1+1 

09030 I DATE 1 = I SHFL1*ISHFL1*K+I SHFL1*L+IDATE( I > 
09040 DO 180 M = 1,22 
09050 MO = M 

09060 IF (IDATEl-IMONTH(M) ) 180,185,180 

09070 180 CONTINUE 

09080 IRET =2 

09090 RETURN 

09100 185 1=1+1 

09110 K = IDATE(I) 

09120 I = I + 1 

09130 GO TO (187,205,210) IPUT 

09140 187 IF CMM .EQ. 2) GO TO 200 

09150 IA (2,4) = IABS(ISHFL1*K)+IDATE(I)+IFILL0 

09160 IA( 3,4) a MO 

09170 IA( 4, 4) = IABS(IDAY1*ISHFL1)+IDAY2+IFILL0 
09180 GO TO (110,130), MM 

09190 200 IA(2,5) = I ABS( I SHFL1*K)+I DATE( I >+I FILLO 
09200 IA( 3, 5) = MO 

09210 IA( 4, 5) = IABS(IDAY1*ISHFL1 )+IDAY2+I FILLO 
09220 GO TO (110,130), MM 
09230 190 IRET = 3 
09240 RETURN 

09250 205 KDATA(l) = IABS( ISHFLI*K)+IDATE( I )+IFILL0 
09260 KDATA( 2) = MO 

09270 KDATA( 3) = IABS( IDAY1*ISHFL1 )+IDAY2+IFILL0 
09280 GO TO 130 

09290 210 MDATA(l) = IABS( ISHFL1*K)+IDATE(I >+IFILL0 
09300 MDATA( 2) = MO 

09310 MDATA( 3) = IABS(IDAY1*ISHFL1)+IDAY2+IFILL0 
09320 GO TO 130 
09330 END 


---THE END 
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** "SORTER". -- SORTS DATA RECORDS BY ID ITEMS 
07/30/71. 08.58.24. 


00100C THIS PROGRAM WAS RE-DESIGNED AND DEVELOPED BY PAUL SIMMONS. 
001 IOC UNITED COMPUTING SYSTEMS. INC.. AND RONALD SCHWARZ. GODDARD 
00120C SPACE FLIGHT CENTER. JULY. 1971. 

00130C 

00140C CURRENT 7/29/71 

00150 PROGRAM SORT! INPUT, OUTPUT, TAPE4, TAPES) 

00160 COMMON I , J.K.NTAPE.KTAPE. IREAD. IRET, IWRITE, JID! 7,4),KID! 7,4) , 
00170+ JQNDEX. JANDEX. JHEADC 3.160). JCODE! 1 60) .MPT.M.N. 

00180+ JPNT< 160). KPNT< 160). KQNDEX, KANDEX, KHEAD! 3.160). KCODE! 160). 
00190+ IZAN. IANDEX. IPAN. JANSC800) .KANSC 700). IDCNT. INUM 
00200 DIMENSION ID!4> 

00210 INUM=-1 
00220 IDCNT«0 
00230 CALL CLOCK! IX) 

00240 CALL DATER< IS) 

00250 PRINT 16. IS. IX 

00260 16 FORMAT! /*PROGRAM I SORTER*. 4X. *DATEt *, A9,4X,*TIMEJ *» A9, ///) 
00270 PRINT. *D0 YOU NEED OPERATING INSTRUCTIONS*. 

00280 READ 17. LANS 
00290 17 FORMAT! A1 ) 

00300 IF !LANS .EQ. 1HN) GO TO 6 

00310 PRINT. /.*THIS PROGRAM SORTS ON THE FIRST FOUR DATA ITEMS IN*. 
00320+ * EACH RECORD*./.*! ID ITEMS). SPECIFY THE ORDER OF*. 

00330+ * IMPORTANCE OF THESE ITEMS WITH*./,*A 1, 2. 3. OR*. 

00340+ * 4 WHEN REQUESTED.* 

00350 6 PRINT. /,*ENTER NAME OF THE DATA FILE TO BE SORTED*. 

00360 21 READ 2. NAME 
00370 2 FORMAT! A7) 

00380 CALL PFUR! 3HRET.NTAPE.NAME.0. I STA) 

00390 IF ! I STA .EQ. 5) GO TO 61 

00400 PRINT. /.*WILL THE DATA FILE BE SORTED INTO ASCENDING !A) OR*. 
00410+ /.*DESCENDING ID) SEQUENCE*. 

00420 5 READ 10,1 SEQ 
00430 10 FORMAT! A1 ) 

00440 IF IISEQ .NE. 1HA .AND. ISEQ .NE. IHD) GO TO 63 
00450 PRINT. /.*ENTER SORTING SEQUENCE HERE* 

00460 DO 12 1*1.4 
00470 12 READ 15. ID! I) 

00480 15 FORMAT III) 

00490 NTAPE=4 
00500 KTAPE=5 
00510 20 ISWIT=0 
00520 ICHANGE=0 

00530 CALL PFUR! 3HRET.NTAPE.NAME. 0. I STA) 

00540 I READ* 1 
00550 CALL RED 
00560 I READ* 2 
00570 25 CALL RED 
00580 GO TO 130,40). IRET 
00590 30 DO 100 1=1,4 
00600 DO 100 J=2,7 
00610 K=ID! I ) 
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** "SORTER" — SORTS DATA RECORDS BY ID ITEMS 
07/30/71. 08.58.24. 


00620C COMPARE FIRST TO NEXT 

00630 IF < JID( J*K)-KI D( J*K))135*1 00# 1 40 

00640 100 CONTINUE , ■ 

00650 105 I RET= 1 

00660 QO TO 00115 

00670 110 IR£T=2 

00680 115 ISWIT*ISWIT+1 

00690 IF < I SUIT .GT. 2) ISWIT=1 

00700 IF CIRET .NE. I SUIT) ICHANGE=1 

00710 IWRITE=IRET 

00720 CALL WRIT 

00730 1READ=IWRI TE 

00740 GO TO 00025 

007 50C ASCENDING SEQUENCE? 

00760 135 IF (ISEQ-iHA) 110* 105# 110 
00770 140 IF (ISEQ-IHA) 105*110*105 
007 80C DID INTERCHANGE OCCUR? 

00790 40 IF ( 1 CHANGE .EQ. 0) GO TO 80 
00800 GO TO <50*45)* IREAD 
00810 45 I WRITE*! 

00820 GO TO 00060 
00830 5.0 IWRITE=2 
00840 60 CALL WRIT 

00850 CALL PFURC 3HREP*KTAPE*NAME*0* 1 STA) 

00860 IDCNT=1 

00870 GO TO 00020 

00880 80 CONTINUE 

00890 PRINT** SORT COMPLETED.* 

00900 PRINT 90* INUM 

00910 90 FORMAT < *YOU HAVE SORTED *#I4»* DATA RECORDS.*) 

00920 STOP 

00930 61 PRINT 44,NAME 

00940 PRINT* *RE-ENTER VALID DATA FILE NAME I** 

00950 GO TO 00021 

00960 44 FORMAT </* DATA FILE **A7** NOT IN PERMANENT STORAGE.*) 

00970 63 PRINT# +ENTER A OR D** 

00980 GO TO 00005 
00990 STOP 
01000 END 

01010 SUBROUTINE RED 

01020 COMMON I* J#K*NTAPE*KTAPE* IREAD* IRET* IWBITE* JID<7* 4),KIDC 7*4)* 
01030+ JQNDEX* JANDEX* JHEADC 3* 1 60 ) * JCODEC 1 60 ) *MPT*M*N* 

01040+ JPNT< 1 60 ) #KPNT< 1 60 ) *KQNDEX* KANDEX* KHEADC 3; 1 60 ) *KCODE< 160)* 

01050+ 1ZAN* IANDEX* IPAN* JANS< 800) *KANS< 700)* IDCNT* INUM 

01060 IF (IDCNT .EQ. 1) GO TO 2 

01070 INUM=INUM+1 

01080 2 GO TO (5*120)# IREAD 

01090 5 READ <NTAPE*175) JQNDEX* JANDEX 

01 100 IF < EQF»NTAPE) 170*10 

OHIO 10 DO 15 1 = 1*4 

01120 15 READ (NTAPE# 180) < JID( J* I ) * J=1 * 7) 

01130 DO 20 1 = 1* JQNDEX 
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** "SORTER" — SORTS DATA RECORDS BY ID ITEMS 
07/30/71. 08.58.24. 


01140 20 READ <NTAPE*180) < JHEAD< J, I ) , J=1 , 3) 
01150 IF < JQNDEX .LE. 65) GO TO 25 
01160 READ <NTAPE, 185) < JCODE< I >, 1=1 , 65) 

01170 READ <NTAPE, 185) <JCODE< I ), 1=66* JQNDEX) 
01180 GO TO 00030 

01190 25 READ <NTAPE,185> < JCODE< I ), 1=1 , JQNDEX) 

01200 30 MPT=22 

01210 M=1 

01220 35 N=M+21 

01230 GO TO <40,55), IREAD 

01240 40 IF < JQNDEX .LE. MPT) GO TO 50 

01250 READ (NTAPE, 190) < JPNT< I ) , I =M,N ) 

01260 45 M=N+ 1 
01270 MPT=MPT+22 
01280 GO TO 00035 

01290 50 READ <NTAPE,190) < JPNT< I ) , I =M, JQNDEX) 
01300 GO TO 00075 

01310 55 IF CKQNDEX .LE. MPT) GO TO 60 
01320 READ CNTAPE, 190) OCPNTC I),I=M,N) 

01330 GO TO 00045 

01340 60 READ < NTAPE, 190) <KPNT< I >, I=M,KQNDEX) 

01350 GO TO 00075 

01360 75 GO TO <80,85), IREAD 

01370 80 IANDEX= JANDEX 

01380 GO TO 00095 

01390 85 IANDEX=KANDEX 

01400 95 J=1 

01410 IZAN=<IANDEX/6)+l 

01420 IPAN=<IZAN-1)*6 

01430 IF < IPAN .EQ. IANDEX) IZAN=IZAN-1 
01440 DO 115 M=1 , IZAN 
01450 K= J+5 

01460 GO TO <100,105), IREAD 

01470 100 READ <NTAPE, 180) < JANS< I ), I=J,K) 

01480 GO TO 00115 

01490 105 READ <NTAPE,180) <KANS< I ) , I = J, K) 

01500 115 J=J+6 
01510 I RET= 1 
01520 RETURN 

01530 120 READ <NTAPE, 175) KQNDEX, KANDEX 
01540 IF < EOF, NTAPE) 170, 125 
01550 125 DO 130 1=1,4 

01560 130 READ <NTAPE, 180) <KID< J, I ) , J= 1 , 7 ) 

01570 DO 135 1=1, KQNDEX 

01580 135 READ <NTAPE,180) < KHEAD< J, I ) , J= 1,3) 
01590 IF < KQNDEX .LE. 65) GO TO 140 
01600 READ <NTAPE, 185) <KCODE< I ), 1=1 , 65 ) 

01610 READ <NTAPE, 185) <KC0DE< I ), 1=66, KQNDEX) 
01620 GO TO 00030 

01630 140 READ <NTAPE,185) <KCODE< I ), I = 1 , KQNDEX) 
01640 GO TO 00030 
01650 170 IB£T=2 


91 



** "SORTER" — SORTS DATA RECORDS BY ID ITEMS 
07/30/71. 08 • 58. 24. 


01660 RETURN 

01670 175 FORMAT (1X.2I5) 

01680 180 FORMAT (1X.7A10) 

01690 185 FORMAT (IX* 6511) 

01700 190 FORMAT MX. 2213) 

01710 END 

01720 SUBROUTINE WRIT 

01730 COMMON I, J.K.NTAPE.KTAPE. IREAD. IRET. IWRITE, JID(7.4),KID(7,4), 
01740+ JQNDEX, JANDEX,JHEAD( 3, 160), JCODE( 1 60),MPT,M,N, 

01750+ JPNTC 160),KPNT( 1 60 ), KQNDEX, KANDEX,KHEAD( 3. 160>,KC0DE( 160), 

01760+ IZAN, IANDEX, IPAN, JANS(800),KANS(700), IDCNT, INUM 

01770 GO TO < 5* 120). 1WRITE 

01780 5 WRITE (KTAPE, 175) JQNDEX, JANDEX 

01790 DO 15 1=1.4 

01800 15 WRITE (KTAPE>180) ( JIDCJ, I ) , J=l,7 ) 

01810 DO 20 1=1. JQNDEX 

01820 20 WRITE (KTAPE, 180) ( JHEAD( J, I ), J=l, 3) 

01830 IF ( JQNDEX .LE. 65) GO TO 25 
01840 WRITE <KTAPE. 185) ( JCODE( I ), I* 1, 65) 

01850 WRITE (KTAPE, 185) (JCODE( I). 1=66. JQNDEX) 

01860 GO TO 00030 

01870 25 WRITE (KTAPE. 185) < JCODE( I ). 1=1 . JQNDEX) 

01880 30 MPT=22 

01890 M= 1 

01900 35 N=M+21 

01910 GO TO (40.55). IWRITE 

01920 40 IF (JQNDEX .LE. MPT) GO TO 50 

01930 WRITE (KTAPE. 190) ( JPNT (I).I=M.N) 

01940 45 M=N+1 
01950 MPT=MPT+22 
01960 GO TO 00035 

01970 50 WRITE (KTAPE. 190) ( JPNT( I >. I=M. JQNDEX) 

01980 GO TO 00075 

01990 55 IF (KQNDEX .LE. MPT) GO TO 60 
02000 WRITE (KTAPE. 190) (KPNT( I ) . I=M.N) 

02010 GO TO 00045 

02020 60 WRITE (KTAPE. 190) ( KPNT ( I ) . I =M. KQNDEX ) 

02030 75 GO TO (80.85). IWRITE 
02040 80 IANDEX= JANDEX 
02050 GO TO 00095 
02060 85 I ANDEX=KANDEX 
02070 95 J=1 
02080 IZAN=(IANDEX/6>+l 
02090 IPAN=( IZAN-1 )*6 

02100 IF (IPAN . EQ. IANDEX)IZAN= IZAN-1 
02110 DO 115 M=l. IZAN 
02120 K= J+5 

02130 GO TO (100.105). IWRITE 

02140 100 WRITE (KTAPE. 180) ( JANS( I ). I=J.K) 

02150 GO TO 00115 

02160 105 WRITE (KTAPE. 180) (KANS( I ) . 1= J.K) . 

02170 115 J=J+6 
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** "SORTER" — SORTS DATA RECORDS BY ID ITEMS 
07/30/71. 08.58.24. 


02180 RETURN 

02190 120 WRITE <KTAPE. 175) KQNDEX, KANDEX 
02200 DO 130 1=1.4 

02210 130 WRITE CKTAPE, 180) (KIDC J, I ), J=l» 7) 

02220 DO 135 I = 1',KQNDEX 

02230 135 WRITE <KTAPE, 180) CKHEADC J, I ), J=l,3) 
02240 IF £ KQNDEX .LE. 65) GO TO 140 
02250 WRITE £KTAPE,185) £KCODE£ I ) , 1=1 , 65) 

02260 WRITE fKTAPE, 185) (KCODEC I ), 1=66. KQNDEX) 
02270 GO TO 00030 

02280 140 WRITE (KTAPE. 185) £KGODE£ I ), 1=1, KQNDEX) 

02290 GO TO 00030 

02300 175 FORMAT C1X.2I5) 

02310 180 FORMAT C1X.7A10) 

02320 185 FORMAT £ IX, 6511) 

02330 190 FORMAT £ IX, 221 3) 

02340 END 



** ’•MERGE” -- MERGES TWO DATA FILES TO FORM A THIRD 
07/30/71. 09.15.18. 


00100C THIS PROGRAM WAS RE-DESIGNED AND DEVELOPED BY PAUL SIMMONS. 
00110C UNITED COMPUTING SYSTEMS. INC.. AND RONALD SCHWARZ. GODDARD 
00120C SPACE FLIGHT CENTER, JULY, 1971. ' x . 

001 30C 

00140 PROGRAM MERGE C INPUT, OUTPUT, TAPE 1 , TAPES, TAPE3) 

00 1 50 COMMON I , J, K.NTAPE, KTAPE, I READ, I RET, I WRI TE, JI DC 7 , 4 > , KI DC 7 , 4) , 

001 60+ JQNDEX, JANDEX, JHEADC 3,160), JCODEC 1 60 ) .MPT.M.N, 

00170+ JPNTC 1 60 ),KPNT< 1 60 ) .KQNDEX.KANDEX, KHEADC 3, 1 60>,KC0DEC 160), 

00180+ IZAN, IANDEX, IPAN, JANSC 600>,KANSC 600), ICOUNT 
00190 DIMENSION IDC4) 

00200 ICOUNT = 0 
00210 NTAPE®1 
00220 MTAPE*2 
00230 KTAPE® 3 
00240 CALL CLOCK(IX) 

00250 CALL DATERCIS) . 

00260 PRINT 4, IS, IX 

00270 PRINT, * ENTER NAME OF THE FIRST FILE TO BE MERGED:*, 

00280 2 READ, NAME 

00290 CALL PFURC 3HRET.NTAPE, NAME, 0, ISTA) 

00300 IF < ISTA .EQ. 5) GO TO 3 
00310 I OK » 1 ' 

00320 PRINT, *ENTER NAME OF THE SECOND FILE TO BE MERGED:*, 

00330 7 READ 5, NAME 

00340 CALL PFUR( 3HRET.MTAPE, NAME, 0, ISTA) 

00350 IF CISTA .EQ. 5) GO TO 3 
00360 PRINT,/ 

00370 PRINT, *ARE THESE FILES IN ASCENDING CA) OR DESCENDING CD) SEQUENC 
CCONT’D) E*. 

00380 READ 10, ISEQ 

00390 PRINT.+WHAT IS THE ORDER OF THE MERGE KEYS? ANSWER THE FOUR* 

00400 PRINT, *QUESTI ON MARKS WITH A 1,2,3, OR 4.* 

00410 DO 15 I ® 1 , 4 
00420 15 READ 20, I DC I) 

00430 I READ® 1 

00440 CALL RED 

00450 35 I READ® 2 

00460 40 CALL RED 

00470 GO TO C45.75), IRET 

00480 45 DO 50 1=1,4 

00490 DO 50 J=2, 7 

00500 K=ID(I> 

005 IOC COMPARE FIRST TO NEXT 

00520 IF C JIDC J,K) -KIDC J,K) ) 60, 50, 70 

00530 50 CONTINUE 

00540 55 IWRITE=1 

00550 CALL WRIT 

00560 I READ® 1 

00570 GO TO 40 

00580C ASCENDING SEQUENCE? 

00590 60 IF CISEQ-1HA) 65,55,65 
00600 65 I WRI TE=2 
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** ••MERGE" — MERGES TWO DATA FILES TO FORM A THIRD 
07/30/71. 09.15.18. 


00610 CALL WRIT 
00620 GO TO 35 

00630 70 IF < I SEQ-1HA) 55* 65* 55 

00 640 C WRITE REMAINDER OF OTHER FILE 

00650 75 GO TO <80*90)* IREAD 

00660 80 I WRITE® 2 

00670 CALL WRIT 

00680 IREAD=2 

00690 CALL RED 

00700 GO TO < 80*95) * IRET 

00710 90 IWRITE=1 

00720 CALL WRIT 

00730 I READ® 1 

00740 CALL RED 

00750 GO TO <90*95). IRET 

00760 95 CONTINUE 

00770 PRINT 110* ICOUNT 

00780 PRINT* *UNDER WHAT NAME SHOULD ALL OF THE MERGED RECORDS** 
00790+ * NOW BE FOUND** 

00800 READ 5* NAME 
00810 IOP = 3HSAV 
00820 GO TO 96 

00830 96 CALL PFURC I0P*KTAPE*NAME*0* ISTA) 

00840 IF CISTA .EQ. 4) GO TO 44 

00850 IF < ISTA .EQ. 0) GO TO 99 t 

00860 44 PRINT* / * *FILE ALREADY PERMANENT.' ENTER A NEW FILE NAME OR* 
00870 PRINT* *ENTER "REPLACE" TO REPLACE CURRENT PERMANENT FILE:*, 
00880 NAMES = NAME 
00890 READ 5*NAME 

00900 IF <NAME .EQ. 7HREPLACE) IOP ® 3HREP 
00910 IF CNAMiE .EQ. 7HREPLACE) NAME = NAMES 
00920 GO TO 96 
00930 99 IACT « 5HSAVED 

00940 IF OOP .EQ. 3HREP) IACT = 8HREPLACED 
00950 PRINT 97.NAME* IACT 
00960 STOP 

00970 3 PRINT 41*NAME 

00980 PRINT* *RE-ENTER VALID FILE NAME*** 

00990 IF OOK .NE. 1) GO TO 2 
01000 GO TO 7 

01010 4 FORMAT! /*PROGRAM* MERGE** 4X**DATES ** A9* 4X**TIME: ** A9* ///) 
01020 5 FORMAT <A7> 

01030 10 FORMAT <A1> 

01040 20 'FORMAT <I1) 

01050 97 FORMAT < /* A7 * * HAS BEEN **A8** AS MERGED FILE.*) 

01060 41 FORMAT! /*DATA FILE **A7,* NOT IN PERMANENT STORAGE.*) 

01070 110 FORMAT! 14** DATA RECORDS HAVE BEEN MERGED.*) 

01080 END 

01090 SUBROUTINE RED 

01 100 COMMON I * J,K*NTAPE*KTAPE* I READ* I RET* IWRITE* JI D<7* 4)*KI D< 7*4) * 
01110+ JQNDEX* JANDEX* JHEAD<3* 1 60)* JCODE! 1 60)*MPT*M*N* 

01120+ JPN T < 1 60 ) * KPNT < 1 60 ) * KQN DEX* KAN DEX * KHEAD <3*160)* KC ODE < 1 60 ) * 


95 



** "MERGE" — MERGES TWO DATA FILES TO FORM A THIRD 
07/30/71. 09.15.18. 


01130+ IZAN# IANDEX#IPAN# JANS( 600 )#KANS( 600 )# ICOUNT 

01140 GO TO. <5# 120). IREAD 

01150 5 READ ( IREAD. 175) JQNDEX# JAN DEX 

01160 IF (EOF# IREAD) 170,10 

01170 10 DO 15 I»l#4 

01180 15 READ (IREAD#180) ( JID< J# I )# J=1 # 7) 

01190 DO 20 1=1# JQNDEX 

01200 20 READ (IREAD#180) ( JHEADC J# I ># J= 1 # 3) 

01210 IF (JQNDEX .LE. 65) GO TO 25 
01220 READ (IREAD#185) ( JCODE( I )# I* 1 # 65) 

01230 READ (IREAD#185) ( JCODE( I )# 1=66# JQNDEX) 

01240 GO TO 30 

01250 25 READ (IREAD#185) ( JCODE( I )# 1=1 # JQNDEX) 

01260 30 MPT=22 

01270 M= 1 

01280 35 N=M+21 

01290 GO TO (40# 55)# IREAD 

01300 40 IF (JQNDEX .LE. MPT) GO TO 50 

01310 READ (IREAD# 190) ( JPNT( I )#I=M#N) 

01320 45 M=N+ 1 
01330 MPT=MPT+22 
01340 GO TO 35 

01350 50 READ (IREAD, 190) (JPNT( I )# I=M# JQNDEX) 
01360 GO TO 75 

01370 55 IF (KQNDEX .LE. MPT) GO TO 60 
01380 READ (IREAD#190) (KPNT( I ># I*M#N) 

01390 GO TO 45 

01400 60 READ (1READ#190) (KPNT( 1 ), 1=M# KQNDEX) 
01410 GO TO 75 

01420 75 GO TO (80#85), IREAD 

01430 80 IANDEX= JANDEX 

01440 GO TO 95 

01450 85 IANDEX=KANDEX 

01460 95 J=1 

01470 IZAN=( IANDEX/6)+l 

01480 IPAN=( IZAN-1 )*6 

01490 IF (IPAN .EQ. IANDEX) IZAN=IZAN-1 
01500 DO 115 M=l# IZAN 
01510 K=J+5 

01520 GO TO ( 100# 105># IREAD 

01530 100 READ (IREAD#180) ( JANS. (I >#I»J#K) 

01540 GO TO 115 

01550 105 READ (IREAD# 180) (KANS( I >.# I=J#K) 

01560 115 J=J+6 
01570 IRET=1 
01580 RETURN 

01590 120 READ (IREAD# 175) KQNDEX# KANDEX 
01600 IF (EOF# IREAD) 170,125 
01610 125 DO 130 I=l#4 

01620 130 READ (IREAD#180> (KI D( J# I )# J=1 #7) 

01630 DO 135 I=1#KQNDEX 

01640 135 READ (IREAD#180) (KHEAD( J# I ) # J=l# 3) 
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** "MERGE" -- MERGES TWO DATA FILES TO FORM A THIRD 
07/30/71. 09.15.18. 


01650 IF (KQNDEX .LE. 65) GO TO 140 
01660 READ (IREAD.185) <KCODE< I ), 1=1 , 65) 

01670 READ (IREAD.185) CKCODEC I ), I =66, KQNDEX) 

01680 GO TO 30 

01690 140 READ <IREAD,185> <KC0DE< I ), 1=1, KQNDEX) 

01700 GO TO 30 
01710 170 IRET=2 
01720 RETURN 

01730 175 FORMAT C IX. 215) 

01740 180 FORMAT (1X.7A10) 

01750 185 FORMAT C IX. 6511) 

01760 190 FORMAT C IX, 221 3) 

01770 END 

01780 SUBROUTINE WRIT 

01790 COMMON I , J.K.NTAPE, KTAPE, I READ, I RET, I WRITE, JID(7,4),KID(7,4>, 
01800+ JQNDEX, JANDEX, JHEADC 3, 1 60 ) , JCODE C 1 60 ),MPT,M, N, 

01810+ JPNT (160), KPNT< 160), KQNDEX, KANDEX, KHEADC 3, 1 60 ) , KCODEt 160), 

01820+ IZAN, IANDEX, IPAN, JANSC 600),KANSC 600), ICOUNT 

01830 ICOUNT = ICOUNT+1 

01840 GO TO <5, 120), IWRITE 

01850 5 WRITE CKTAPE, 175) JQNDEX, JANDEX 

01860 DO 15 1*1,4 

01870 15 WRITE CKTAPE, 180) < JIDC J, I ), J=1 , 7) 

01880 DO 20 1=1, JQNDEX 

01890 20 WRITE (KTAPE, 180) < JHEADt J, I ), J=l, 3) 

01900 IF (JQNDEX .LE. 65) GO TO 25 
01910 WRITE (KTAPE, 185) < JC0DE< I ), I* 1, 65) 

01920 WRITE (KTAPE, 185) < JCODEC I ), 1=66, JQNDEX) 

01930 GO TO 30 

01940 25 WRITE (KTAPE, 185) ( JCODE( I ), 1=1 , JQNDEX) 

01950 30 MPT=22 

01960 M=1 

01970 35 N=M+21 

01980 GO TO (40,55), IWRITE 

01990 40 IF (JQNDEX .LE. MPT) GO TO 50 

02000 WRITE (KTAPE, 190) < JPNT< I ), I=M,N) 

02010 45 M=N+1 
02020 MPT=MPT+22 
02030 GO TO 35 

02040 50 WRITE (KTAPE, 190) C JPNT< I ), I=M, JQNDEX) 

02050 GO TO 75 

02060 55 IF (KQNDEX .LE. MPT) GO TO 60 
02070 WRITE (KTAPE, 190) (KPNTC I ) , I=M,N) 

02080 GO TO 45 

02090 60 WRITE (KTAPE, 190) (KPNTC I ), I *M, KQNDEX) 

02100 75 GO TO (80,85), IWRITE 

02110 80 IANDEX* JANDEX 

02120 GO TO 95 

02130 85 IANDEX=KANDEX 

02140 95 J=1 

02150 IZAN=(IANDEX/6)+i 

02160 IPAN=< IZAN- 1 )*6 
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02170 IF < I PAN .EQ. I ANDEX > I ZAN= IZAN- 1 
02180 DO 115 M= 1*1 ZAN 
02190 K® J+5 

02200 GO TO < 100*105)* IWRITE 

02210 100 WRITE <KTAPE, ISO) C JAM SC I ) * I=J*K) 

02220 GO TO 115 

02230 105 WRITE <KTAPE*180) <KANS< I )* I=J*K) 

02240 115 J=J+6 
02250 RETURN 

02260 120 WRITE CKTAPE*175) KQNDEX* KANDEX 
02270 DO 130 1 = 1*4 

02280 130 WRITE CKTAPE* 180) <KID( J* I ) * J= 1 * 7 ) 

02290 DO 135 I=1*KGNDEX 

02300 135 WRITE CKTAPE* 180) CKHEADC J* I)» J=1j3) 
02310 IF CKQNDEX .LE. 65) GO TO 140 
02320 WRITE CKTAPE* 185) CKCODEC I )* 1=1, 65) 

02330 WRITE CKTAPE* 185) CKCODEC 1 )* I=66*KQNDEX> 
02340 GO TO 30 

02350 140 WRITE CKTAPE* 185) C KCODEC I ) * I = 1 * KQNDEX) 

02360 GO TO 30 

02370 175 FORMAT C IX* 215) 

02380 180 FORMAT C1X*7A10) 

02390 185 FORMAT C IX* 6511) 

02400 190 FORMAT C IX* 221 3) 

02410 END 


---THE END--- 
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